SUBROUTINE DPRTL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN TRIPLEX LOWER CASE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-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--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRTL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.6)GOTO1010 GOTO1019 1010 CONTINUE CALL DRTL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(7.LE.ICHARN.AND.ICHARN.LE.12)GOTO1020 GOTO1029 1020 CONTINUE CALL DRTL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IF(13.LE.ICHARN.AND.ICHARN.LE.18)GOTO1030 GOTO1039 1030 CONTINUE CALL DRTL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1039 CONTINUE C IF(ICHARN.GE.19)GOTO1040 GOTO1049 1040 CONTINUE CALL DRTL4(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1049 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRTL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRTN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN TRIPLEX NUMERIC. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-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--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRTN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.6)GOTO1010 GOTO1019 1010 CONTINUE CALL DRTN1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(ICHARN.GE.7)GOTO1020 GOTO1029 1020 CONTINUE CALL DRTN2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRTN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRTS(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN TRIPLEX SYMBOLS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-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--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MARCH 1982. C UPDATED --MARCH 1987. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRTS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHSY(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.8)GOTO1010 GOTO1019 1010 CONTINUE CALL DRTS1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(ICHARN.GE.9)GOTO1020 GOTO1029 1020 CONTINUE CALL DRTS2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRTS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRTU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN TRIPLEX UPPER CASE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-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--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRTU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.6)GOTO1010 GOTO1019 1010 CONTINUE CALL DRTU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(7.LE.ICHARN.AND.ICHARN.LE.13)GOTO1020 GOTO1029 1020 CONTINUE CALL DRTU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IF(14.LE.ICHARN.AND.ICHARN.LE.19)GOTO1030 GOTO1039 1030 CONTINUE CALL DRTU3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1039 CONTINUE C IF(ICHARN.GE.20)GOTO1040 GOTO1049 1040 CONTINUE CALL DRTU4(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1049 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRTU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRUN(XTEMP1,XTEMP2,MAXNXT, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--CARRY OUT A RUNS ANALYSIS C TO TEST FOR RANDOMNENSS. 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--JULY 1984. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION W(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),W(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPRU' ISUBN2='N ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IFOUND='NO' IERROR='NO' C MAXV2=1 MINN2=2 C IFOUND='YES' C NLEFT=0 C ICASEQ='UNKN' C C ******************************** C ** TREAT THE RUNS ANALYSIS 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 DPRUN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3 52 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGQ 53 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)MAXNXT 55 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) C C *********************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR MORE. ** C *********************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPRUN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A RUNS ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 5-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='5' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ********************************************* C ** STEP 5-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE RESPONSE VARIABLE. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************* C ISTEPN='5' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO510 IF(ICASEQ.EQ.'SUBS')GOTO520 IF(ICASEQ.EQ.'FOR')GOTO530 C 510 CONTINUE DO515I=1,NLEFT ISUB(I)=1 515 CONTINUE NQ=NLEFT GOTO550 C 520 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO550 C 530 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO550 C 550 CONTINUE IF(NQ.GE.MINN2)GOTO560 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPRUN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553)IHLEFT,IHLEF2 553 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' (FROM WHICH A RUNS ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556)MINN2 556 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557) 557 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,559)(IANS(I),I=1,IWIDTH) 559 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 560 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO570I=1,IMAX IF(ISUB(I).EQ.0)GOTO570 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I) C 570 CONTINUE NS=J C C **************************************************************** C ** STEP 8-- C ** PREPARE FOR ENTRANCE INTO DPRUN2-- C ** SET THE WEIGHT VECTOR TO UNITY THROUGHOUT. C **************************************************************** C ISTEPN='8' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1110I=1,NS W(I)=1.0 1110 CONTINUE C C ********************************* C ** STEP 9-- ** C ** FORM THE RUNS ANALYSIS ** C ********************************* C ISTEPN='9' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** FROM DPRUN, AS WE ARE ABOUT TO CALL DPRUN2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212)NLEFT,MAXN,NS 1212 FORMAT('NLEFT,MAXN,NS = ',3I8) CALL DPWRST('XXX','BUG ') DO1215I=1,NS WRITE(ICOUT,1216)I,Y(I),W(I) 1216 FORMAT('I,Y(I),W(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 1215 CONTINUE CCCCC IBUGA3='ABCD' WRITE(ICOUT,1231)IBUGA3 1231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 1290 CONTINUE C CALL DPRUN2(Y,W,NS,XTEMP1,XTEMP2,MAXNXT,IBUGA3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRUN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGQ 9013 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NLEFT,NS 9014 FORMAT('NLEFT,NS = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ICASEQ 9015 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IFOUND,IERROR 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRUN2(Y,W,N,XTEMP1,XTEMP2,MAXNXT,IBUGA3,IERROR) C C PURPOSE--THIS ROUTINE CARRIES OUT A RUNS ANALYSIS C FOR THE DATA IN THE INPUT VECTOR Y. C NOTE--ASSUMPTION--DATA COLLECTED SEQUENTIALLY IN TIME. C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C OF EQUALLY-SPACED OBSERVATIONS C TO BE SMOOTHED. C N = THE INTEGER NUMBER OF C OBSERVATIONS IN THE VECTOR Y. C NOTE--THE ANALYSIS CONSISTS OF FIRST DETERMINING C THE OBSERVED NUMBER OF RUNS FROM THE DATA, C AND THEN COMPUTING C THE EXPECTED NUMBER OF RUNS, C THE STANDARD DEVIATION OF THE NUMBER OF RUNS, C AND THE RESULTING STANDARDIZED STATISTIC C FOR THE NUMBER OF RUNS FOR RUNS OF VARIOUS C LENGTHS. C THIS IS DONE FOR RUNS UP, RUNS DOWN, AND C RUNS UP AND DOWN. C THIS RUNS ANSLYSIS IS A USEFUL DISTRIBUTION-FREE C TEST OF THE RANDOMNESS OF A DATA SET. C OUTPUT--4 PAGES OF AUTOMATIC PRINTOUT C CONSISTING OF THE OBSERVED NUMBER, C EXPECTED NUMBER, STANDARD DEVIATION C AND RESULTING STANDARDIZED STATISTIC C FOR RUNS OF VARIOUS LENGTHS. C AND THE CUMULATIVE FREQUENCY. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI 77 FORTRAN. C REFERENCES--LEVENE AND WOLFOWITZ, ANNALS OF MATHEMATICAL C STATISTICS, 1944, PAGES 58-69; C ESPECIALLY PAGES 60, 63, AND 64. C REFERENCES--BRADLEY, DISTRIBUTION-FREE STATISTICAL TESTS, C 1968, CHAPTER 12, PAGES 271-282. 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--JULY 1984. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION W(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION NRUL(16), NRDL(16), NRTL(16), NRULG(16), NRDLG(16) DIMENSION NRTLG(16) DIMENSION ENRUL(16),ENRTL(16),ENRULG(16),ENRTLG(16) DIMENSION SNRUL(16),SNRTL(16),SNRULG(16),SNRTLG(16) DIMENSION ZNRUL(16),ZNRDL(16),ZNRTL(16),ZNRULG(16),ZNRDLG(16) DIMENSION ZNRTLG(16) DIMENSION C1(15),C2(15),C3(15),C4(15) DIMENSION ANRUL(16),ANRDL(16),ANRTL(16) DIMENSION ANRULG(16),ANRDLG(16),ANRTLG(16) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C------DATA STATEMENTS------------------------------------------------ C DATA C1(1),C1(2),C1(3),C1(4),C1(5),C1(6),C1(7),C1(8),C1(9),C1(10), 1C1(11),C1(12),C1(13),C1(14),C1(15) 1/ .4236111111E+00, .1126675485E+00, .4191688713E-01, 1 .1076912487E-01, .2003959238E-02, .3023235799E-03, 1 .3911555473E-04, .4459038843E-05, .4551105210E-06, 1 .4207466837E-07, .3555930927E-08, .2768273257E-09, 1 .1997821524E-10, .1343876568E-11, .8465610177E-13/ DATA C2(1),C2(2),C2(3),C2(4),C2(5),C2(6),C2(7),C2(8),C2(9),C2(10), 1C2(11),C2(12),C2(13),C2(14),C2(15) 1/-.4819444444E+00, -.1628284832E+00, -.9690696649E-01, 1 -.3778106786E-01, -.9289228716E-02, -.1724429252E-02, 1 -.2638557888E-03, -.3466965096E-04, -.4004129153E-05, 1 -.4130382587E-06, -.3851876069E-07, -.3279103786E-08, 1 -.2568491117E-09, -.1863433868E-10, -.1259220466E-11/ DATA C3(1),C3(2),C3(3),C3(4),C3(5),C3(6),C3(7),C3(8),C3(9),C3(10), 1C3(11),C3(12),C3(13),C3(14),C3(15) 1/ .1777777778E+00, .7916666667E-01, .4738977072E-01, 1 .1274801587E-01, .2338606059E-02, .3461358734E-03, 1 .4407121770E-04, .4960020603E-05, .5010387575E-06, 1 .4592883352E-07, .3854170274E-08, .2982393839E-09, 1 .2141205844E-10, .1433843200E-11, .8996663214E-13/ DATA C4(1),C4(2),C4(3),C4(4),C4(5),C4(6),C4(7),C4(8),C4(9),C4(10), 1C4(11),C4(12),C4(13),C4(14),C4(15) 1/-.3222222222E+00, -.5972222222E-01, -.1130268959E+00, 1 -.4696428571E-01, -.1123273065E-01, -.2025170849E-02, 1 -.3029410411E-03, -.3912824548E-04, -.4459234519E-05, 1 -.4551128785E-06, -.4207469124E-07, -.3555931110E-08, 1 -.2768273269E-09, -.1997821525E-10, -.1343876568E-11/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPRU' ISUBN2='N2 ' 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 DPRUN2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,IBUGA3 52 FORMAT('N,IBUGA3 = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') DO56I=1,N WRITE(ICOUT,57)I,Y(I),W(I) 57 FORMAT('I,Y(I),W(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 56 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N.LT.1)GOTO110 GOTO119 110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DPRUN2--THE NUMBER OF OBSERVATIONS ', 1'IN THE RESPONSE VARIABLE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112)N 112 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NOTE FROM DPRUN2--THE RESPONSE VARIABLE ', 1'ONLY HAS 1 ELEMENT') CALL DPWRST('XXX','BUG ') GOTO9000 129 CONTINUE C HOLD=Y(1) DO135I=2,N IF(Y(I).NE.HOLD)GOTO139 135 CONTINUE 130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131)HOLD 131 FORMAT('***** NOTE FROM DPRUN2--THE RESPONSE VARIABLE ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') GOTO9000 139 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** FORM THE SEQUENTIAL DIFFERENCE TABLE ** C ******************************************** C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C AN=N NM1=N-1 DO100I=1,NM1 IP1=I+1 XTEMP1(I)=Y(IP1)-Y(I) 100 CONTINUE C C *********************************************** C ** STEP 12-- ** C ** ZERO-OUT THE 6 'NUMBER OF RUNS' VECTORS ** C *********************************************** C ISTEPN='12' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO200I=1,16 NRUL(I)=0 NRDL(I)=0 NRTL(I)=0 NRULG(I)=0 NRDLG(I)=0 NRTLG(I)=0 200 CONTINUE C C *********************************************************** C ** STEP 13-- ** C ** DETERMINE THE NUMBER OF RUNS UP OF LENGTH EXACTLY I ** C ** AND THE NUMBER OF RUNS DOWN OF LENGTH EXACTLY I ** C ** DETERMINE THE LENGTH OF THE LONGEST RUN UP ** C ** AND THE LENGTH OF THE LONGEST RUN DOWN ** C *********************************************************** C ISTEPN='13' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C LENUP=0 LENDN=0 MAXLNU=0 MAXLND=0 DO300I=1,NM1 IF(XTEMP1(I).EQ.0.0.AND.LENUP.GE.1)LENUP=LENUP+1 IF(XTEMP1(I).EQ.0.0.AND.LENDN.GE.1)LENDN=LENDN+1 IF(XTEMP1(I).EQ.0.0.AND.LENUP.EQ.0.AND.LENDN.EQ.0)LENUP=LENUP+1 CCCCC IF(XTEMP1(I).GT.0.0.AND.LENDN.GE.1.AND.LENDN.LE.N) IF(XTEMP1(I).GT.0.0.AND.LENDN.GE.1.AND.LENDN.LE.15) 1NRDL(LENDN)=NRDL(LENDN)+1 IF(XTEMP1(I).GT.0.0.AND.LENDN.GE.1.AND.LENDN.GE.16) 1NRDL(16)=NRDL(16)+1 IF(XTEMP1(I).GT.0.0)LENDN=0 IF(XTEMP1(I).GT.0.0)LENUP=LENUP+1 CCCCC IF(XTEMP1(I).LT.0.0.AND.LENUP.GE.1.AND.LENUP.LE.N) IF(XTEMP1(I).LT.0.0.AND.LENUP.GE.1.AND.LENUP.LE.15) 1NRUL(LENUP)=NRUL(LENUP)+1 IF(XTEMP1(I).LT.0.0.AND.LENUP.GE.1.AND.LENUP.GE.16) 1NRUL(16)=NRUL(16)+1 IF(XTEMP1(I).LT.0.0)LENUP=0 IF(XTEMP1(I).LT.0.0)LENDN=LENDN+1 CCCCC IF(I.EQ.NM1. AND.LENDN.GE.1.AND.LENDN.LE.N) IF(I.EQ.NM1. AND.LENDN.GE.1.AND.LENDN.LE.15) 1NRDL(LENDN)=NRDL(LENDN)+1 IF(I.EQ.NM1. AND.LENDN.GE.1.AND.LENDN.GE.16) 1NRDL(16)=NRDL(16)+1 CCCCC IF(I.EQ.NM1. AND.LENUP.GE.1.AND.LENUP.LE.N) IF(I.EQ.NM1. AND.LENUP.GE.1.AND.LENUP.LE.15) 1NRUL(LENUP)=NRUL(LENUP)+1 IF(I.EQ.NM1. AND.LENUP.GE.1.AND.LENUP.GE.16) 1NRUL(16)=NRUL(16)+1 IF(LENUP.GT.MAXLNU)MAXLNU=LENUP IF(LENDN.GT.MAXLND)MAXLND=LENDN 300 CONTINUE C C ************************************************************** C ** STEP 14-- ** C ** DETERMINE THE NUMBER OF RUNS TOTAL OF LENGTH EXACTLY I ** C ** AND THE LENGTH OF THE LONGEST RUN UP OR DOWN ** C ************************************************************** C ISTEPN='14' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO400I=1,16 NRTL(I)=NRUL(I)+NRDL(I) 400 CONTINUE MAXLNT=MAXLNU IF(MAXLND.GT.MAXLNU)MAXLNT=MAXLND C C *********************************************************** C ** STEP 15-- ** C ** DETERMINE THE NUMBER OF RUNS UP OF LENGTH I OR MORE ** C ** AND THE NUMBER OF RUNS DOWN OF LENGTH I OR MORE ** C ** AND THE NUMBER OF RUNS TOTAL OF LENGTH I OR MORE ** C *********************************************************** C ISTEPN='15' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NRULG(16)=NRUL(16) NRDLG(16)=NRDL(16) NRTLG(16)=NRTL(16) DO500I=1,15 J=16-I JP1=J+1 NRULG(J)=NRULG(JP1)+NRUL(J) NRDLG(J)=NRDLG(JP1)+NRDL(J) NRTLG(J)=NRTLG(JP1)+NRTL(J) 500 CONTINUE C C **************************************************************** C ** STEP 16-- C ** DETERMINE THE NUMBER OF POSITIVE, ZERO, AND NEGATIVE ENTRIES C ** IN THE DIFFERENCE TABLE. IF RANDOM, THE NUMBER OF POSITIVE C ** APPROXIMATELY EQUAL TO THE NUMBER OF NEGATIVE C **************************************************************** C ISTEPN='16' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NNEG=0 NZER=0 NPOS=0 DO800I=1,NM1 IF(XTEMP1(I).LT.0.0)NNEG=NNEG+1 IF(XTEMP1(I).EQ.0.0)NZER=NZER+1 IF(XTEMP1(I).GT.0.0)NPOS=NPOS+1 800 CONTINUE C C **************************************************************** C ** STEP 17-- C ** COMPUTE THE EXPECTED NUMBER OF RUNS UP OF LENGTH EXACTLY I = C ** THE EXPECTED NUMBER OF RUNS DOWN OF LENGTH EXACTLY I = C ** ONE HALF THE EXPECTED NUMBER OF RUNS TOTAL OF LENGTH EXACTLY C **************************************************************** C ISTEPN='17' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DEN=6.0 DO2000I=1,15 AI=I ENRUL(I)=AN*(AI*AI+3.0*AI+1.0)-(AI*AI*AI+3.0*AI*AI-AI-4.0) DEN=DEN*(AI+3.0) ENRUL(I)=ENRUL(I)/DEN ENRTL(I)=2.0*ENRUL(I) 2000 CONTINUE C C **************************************************************** C ** STEP 18- C ** COMPUTE THE EXPECTED NUMBER OF RUNS UP OF LENGTH I OR MORE = C ** THE EXPECTED NUMBER OF RUNS DOWN OF LENGTH I OR MORE = C ** ONE HALF THE EXPECTED NUMBER OF RUNS TOTAL OF LENGTH I OR MO C **************************************************************** C ISTEPN='18' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DEN=2.0 DO2100I=1,15 AI=I ENRULG(I)=AN*(AI+1.0)-(AI*AI+AI-1.0) DEN=DEN*(AI+2.0) ENRULG(I)=ENRULG(I)/DEN ENRTLG(I)=2.0*ENRULG(I) 2100 CONTINUE C C **************************************************************** C ** STEP 19-- C ** COMPUTE THE STANDARD DEV. OF THE NUMBER OF RUNS UP OF LENGTH C ** THE STANDARD DEV. OF THE NUMBER OF RUNS DOWN OF LENGTH EXACT C ** SQRT(0.5)* THE STAND. DEV. OF THE NUMBER OF RUNS TOTAL OF LE C **************************************************************** C ISTEPN='19' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2500I=1,15 ARG=C1(I)*AN+C2(I) SNRTL(I)=0.0 IF(ARG.GT.0.0)SNRTL(I)=SQRT(ARG) SNRUL(I)=SQRT(0.5)*SNRTL(I) 2500 CONTINUE C C **************************************************************** C ** STEP 20-- C ** COMPUTE THE STAND. DEV. OF THE NUMBER OF RUNS UP OF LENGTH I C ** THE STAND. DEV. OF THE NUMBER OF RUNS DOWN OF LENGTH I OR MO C ** SQRT(0.5)* THE STAND. DEV. OF THE NUMBER OF RUNS TOTAL OF LE C **************************************************************** C ISTEPN='20' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2600I=1,15 ARG=C3(I)*AN+C4(I) SNRTLG(I)=0.0 IF(ARG.GT.0.0)SNRTLG(I)=SQRT(ARG) SNRULG(I)=SQRT(0.5)*SNRTLG(I) 2600 CONTINUE C C ************************* C ** STEP 21-- ** C ** FORM Z STATISTICS ** C ************************* C ISTEPN='21' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO3100I=1,15 C STAT=NRUL(I) ZNRUL(I)=(-99999.99) IF(SNRUL(I).GT.0.0)ZNRUL(I)=(STAT -ENRUL(I))/SNRUL(I) C STAT=NRDL(I) ZNRDL(I)=(-99999.99) IF(SNRUL(I).GT.0.0)ZNRDL(I)=(STAT -ENRUL(I))/SNRUL(I) C STAT=NRTL(I) ZNRTL(I)=(-99999.99) IF(SNRTL(I).GT.0.0)ZNRTL(I)=(STAT -ENRTL(I))/SNRTL(I) C STAT=NRULG(I) ZNRULG(I)=(-99999.99) IF(SNRULG(I).GT.0.0)ZNRULG(I)=(STAT -ENRULG(I))/SNRULG(I) C STAT=NRDLG(I) ZNRDLG(I)=(-99999.99) IF(SNRULG(I).GT.0.0)ZNRDLG(I)=(STAT -ENRULG(I))/SNRULG(I) C STAT=NRTLG(I) ZNRTLG(I)=(-99999.99) IF(SNRTLG(I).GT.0.0)ZNRTLG(I)=(STAT -ENRTLG(I))/SNRTLG(I) C 3100 CONTINUE C DO3200I=1,15 ANRUL(I)=NRUL(I) ANRDL(I)=NRDL(I) ANRTL(I)=NRTL(I) ANRULG(I)=NRULG(I) ANRDLG(I)=NRDLG(I) ANRTLG(I)=NRTLG(I) 3200 CONTINUE C C **************************** C ** STEP 22-- ** C ** WRITE EVERYTHING OUT ** C **************************** C ISTEPN='22' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO4990 C IMAX=15 IF(IMAX.GT.N)IMAX=N IMAX2=10 IF(IMAX2.GT.N)IMAX2=N CCCCC WRITE(ICOUT,998) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4102) 4102 FORMAT(' RUNS UP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4104) 4104 FORMAT(' STATISTIC = NUMBER OF RUNS UP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4105) 4105 FORMAT(' OF LENGTH EXACTLY I') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4106) 4106 FORMAT(' I STAT EXP(STAT) SD(STAT) Z ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO4110I=1,IMAX2 WRITE(ICOUT,4111)I,ANRUL(I),ENRUL(I),SNRUL(I),ZNRUL(I) 4111 FORMAT(I4,F12.1,F12.4,F12.4,F12.2) CALL DPWRST('XXX','BUG ') 4110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4124) 4124 FORMAT(' STATISTIC = NUMBER OF RUNS UP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4125) 4125 FORMAT(' OF LENGTH I OR MORE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO4130I=1,IMAX2 WRITE(ICOUT,4111)I,ANRULG(I),ENRULG(I),SNRULG(I),ZNRULG(I) CALL DPWRST('XXX','BUG ') 4130 CONTINUE C CCCCC WRITE(ICOUT,998) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4202) 4202 FORMAT(' RUNS DOWN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4204) 4204 FORMAT(' STATISTIC = NUMBER OF RUNS DOWN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4205) 4205 FORMAT(' OF LENGTH EXACTLY I') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO4210I=1,IMAX2 WRITE(ICOUT,4111)I,ANRDL(I),ENRUL(I),SNRUL(I),ZNRDL(I) CALL DPWRST('XXX','BUG ') 4210 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4224) 4224 FORMAT(' STATISTIC = NUMBER OF RUNS DOWN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4225) 4225 FORMAT(' OF LENGTH I OR MORE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO4230I=1,IMAX2 WRITE(ICOUT,4111)I,ANRDLG(I),ENRULG(I),SNRULG(I),ZNRDLG(I) CALL DPWRST('XXX','BUG ') 4230 CONTINUE C CCCCC WRITE(ICOUT,998) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4302) 4302 FORMAT(' RUNS TOTAL = RUNS UP + RUNS DOWN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4304) 4304 FORMAT(' STATISTIC = NUMBER OF RUNS TOTAL') CALL DPWRST('XXX','BUG ') WRITE (IPR,4305) 4305 FORMAT(' OF LENGTH EXACTLY I') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO4310I=1,IMAX2 WRITE(ICOUT,4111)I,ANRTL(I),ENRTL(I),SNRTL(I),ZNRTL(I) CALL DPWRST('XXX','BUG ') 4310 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4324) 4324 FORMAT(' STATISTIC = NUMBER OF RUNS TOTAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4325) 4325 FORMAT(' OF LENGTH I OR MORE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO4330I=1,IMAX2 WRITE(ICOUT,4111)I,ANRTLG(I),ENRTLG(I),SNRTLG(I),ZNRTLG(I) CALL DPWRST('XXX','BUG ') 4330 CONTINUE C CCCCC WRITE(ICOUT,998) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4401)MAXLNU 4401 FORMAT(' LENGTH OF THE LONGEST RUN UP = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4402)MAXLND 4402 FORMAT(' LENGTH OF THE LONGEST RUN DOWN = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4403)MAXLNT 4403 FORMAT(' LENGTH OF THE LONGEST RUN UP OR DOWN = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4411)NPOS 4411 FORMAT(' NUMBER OF POSITIVE DIFFERENCES = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4412)NNEG 4412 FORMAT(' NUMBER OF NEGATIVE DIFFERENCES = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4413)NZER 4413 FORMAT(' NUMBER OF ZERO DIFFERENCES = ',I5) CALL DPWRST('XXX','BUG ') CC998 FORMAT(1H1) C 4990 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 DPRUN2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,IBUGA3,IERROR 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') DO9016I=1,N WRITE(ICOUT,9017)I,Y(I),W(I) 9017 FORMAT('I,Y(I),W(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9016 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPRUNS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM A RUN-SEQUENCE 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--82/7 C ORIGINAL VERSION--DECEMBER 1977. C UPDATED --JANUARY 1978. C UPDATED --FEBRUARY 1978. C UPDATED --MAY 1978. C UPDATED --JULY 1978. C UPDATED --JANUARY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPRU' ISUBN2='NS ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=1 MINN2=1 C C **************************************** C ** TREAT THE RUN-SEQUENCE PLOT CASE ** C **************************************** C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRUNS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFOUND='YES' ICASPL='RUNS' C C ******************************************************* C ** STEP 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(3) IHLEF2=IHARG2(3) 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 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *********************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPRUNS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A RUN-SEQUENCE PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)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(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,2X,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ********************************************* C ** STEP 5-- ** C ** TEMPORARILY FORM THE VARIABLE D(.) ** C ** WHICH WILL HOLD THE RESPONSE VARIABLE ** C ** (FOR THE TIME BEING ONLY). ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************* C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO510 IF(ICASEQ.EQ.'SUBS')GOTO520 IF(ICASEQ.EQ.'FOR')GOTO530 C 510 CONTINUE DO515I=1,NLEFT ISUB(I)=1 515 CONTINUE NQ=NLEFT GOTO550 C 520 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO550 C 530 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO550 C 550 CONTINUE IF(NQ.GE.MINN2)GOTO560 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPRUNS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553)IHLEFT,IHLEF2 553 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' (FOR WHICH A RUN-SEQUENCE PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556)MINN2 556 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557) 557 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,559)(IANS(I),I=1,IWIDTH) 559 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 560 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO570I=1,IMAX IF(ISUB(I).EQ.0)GOTO570 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)D(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)D(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)D(J)=RES(I) IF(ICOLL.EQ.MAXCP3)D(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)D(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)D(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)D(J)=TAGPLO(I) C 570 CONTINUE NS=J C C ************************************************************* C ** STEP 6-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. ** C ** RESET THE D(.) VARIABLE TO ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NPLOTP=NS C IF(NPLOTP.LE.0)GOTO650 DO600I=1,NPLOTP Y(I)=D(I) X(I)=I 600 CONTINUE C DO610I=1,NPLOTP D(I)=1.0 610 CONTINUE C 650 CONTINUE NPLOTV=1 C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRUNS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9090 DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPRUPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A RUNS PLOT. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--SEPTEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR 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='DPRU' ISUBN2='PL ' C IFOUND='NO' IERROR='NO' C IFOUND='YES' IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) 101 FORMAT('***** ERROR IN DPRUPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) 102 FORMAT(' RUNS PLOT CAPABILITY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103) 103 FORMAT(' NOT YET AVAILABLE') CALL DPWRST('XXX','BUG ') C RETURN END SUBROUTINE DPSACO(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG, 1IANSSV,IREPMX,IPOINT, 1ISACNC, 1IBUGS2,ISUBRO,IFOUND,IERROR) C C PURPOSE--SAVE (FOR FUTURE USE BY THE REEXECUTE COMMAND) C SELECTED COMMANDS IN THE (RECENT) COMMAND LIST. C THE RECENT COMMAND LIST CONSISTS OF THE C LAST IREPMX (= 50) COMMANDS. C LAST MAXLIS (==> 200) COMMANDS. APRIL 1993 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--APRIL 1986. C UPDATED --APRIL 1993. SOFT-CODE DIMEN. FOR IANSSV() C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1993 INCLUDE 'DPCOPA.INC' CHARACTER*4 IANSLC CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*1 IANSSV CHARACTER*80 ISACNC C CHARACTER*4 IBUGS2 CHARACTER*4 ISUBRO CHARACTER*4 IERROR CHARACTER*4 IFOUND C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*1 IC1 CHARACTER*4 IC4 CHARACTER*80 ISTRIN CHARACTER*80 ISTRI2 C CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C DIMENSION IANSLC(*) DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) CCCCC THE FOLLOWING 2 LINES WERE CHANGED APRIL 1993 CCCCC DIMENSION IANSSV(50,80) CCCCC DIMENSION ITAB(50) DIMENSION IANSSV(MAXLIS,MAXCIS) DIMENSION ITAB(MAXLIS) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOF2.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSA' ISUBN2='CO ' C IFOUND='NO' IERROR='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SACO')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPSACO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGS2,ISUBRO,IFOUND,IERROR 52 FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IWIDTH 53 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,54)(IANSLC(I),I=1,IWIDTH) 54 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)NUMARG 55 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO58 DO56I=1,NUMARG WRITE(ICOUT,57)I,IHARG(I) 57 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 56 CONTINUE 58 CONTINUE CCCCC THE FOLLOWING 2 LINES WERE CHANGED APRIL 1993 CCCCC WRITE(ICOUT,61)IREPMX,IPOINT CCC61 FORMAT('IREPMX,IPOINT = ',I8,2X,I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)MAXLIS,IPOINT 61 FORMAT('MAXLIS,IPOINT = ',I8,2X,I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 CCCCC DO62J=1,IREPMX DO62J=1,MAXLIS WRITE(ICOUT,63)J,(IANSSV(J,I),I=1,80) 63 FORMAT('J,(IANSSV(J,I),I=1,80) = ',I8,2X,80A1) CALL DPWRST('XXX','BUG ') 62 CONTINUE WRITE(ICOUT,71)ISACNU 71 FORMAT('ISACNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ISACNA 72 FORMAT('ISACNA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)ISACST 73 FORMAT('ISACST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)ISACFO 74 FORMAT('ISACFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)ISACAC 75 FORMAT('ISACAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)ISACFO 76 FORMAT('ISACFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)ISACCS 77 FORMAT('ISACCS = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81)ISACNC 81 FORMAT('ISACNC = ',A80) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFOUND='YES' C C ****************************************************** C ** STEP 11-- ** C ** DETERMINE IF HAVE AN EXPLICIT FILE REFERENCE ** C ** WHERE THE COMMANDS WILL BE SAVED, OR WILL THEY ** C ** BE SAVED IN THE DEFAULT FILE (DPSACF.TEX)? ** C ****************************************************** C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFILWD=(-999) C DO1100I=1,80 IC4=IANSLC(I) ISTRIN(I:I)=IC4(1:1) 1100 CONTINUE C IWORD=1 ISTART=1 ISTOP=80 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,ISTRI2,NCSTR2, 1IBUGS2,ISUBRO,IERROR) C IF(NUMARG.LE.0)GOTO1129 IWORD=2 ISTART=1 ISTOP=80 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,ISTRI2,NCSTR2, 1IBUGS2,ISUBRO,IERROR) IF(NCSTR2.LE.0)GOTO1129 DO1121I=1,NCSTR2 IF(ISTRI2(I:I).EQ.'.')GOTO1122 1121 CONTINUE GOTO1129 1122 CONTINUE IFILWD=2 GOTO1190 1129 CONTINUE C IF(NUMARG.LE.1)GOTO1139 IWORD=3 ISTART=1 ISTOP=80 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,ISTRI2,NCSTR2, 1IBUGS2,ISUBRO,IERROR) IF(NCSTR2.LE.0)GOTO1139 DO1131I=1,NCSTR2 IF(ISTRI2(I:I).EQ.'.')GOTO1132 1131 CONTINUE GOTO1139 1132 CONTINUE IFILWD=3 GOTO1190 1139 CONTINUE C 1190 CONTINUE ISTAM1=0 IF(IFILWD.EQ.2.OR.IFILWD.EQ.3)ISTAM1=1 C C ******************************* C ** STEP 12-- ** C ** COPY OVER FILE VARIABLES ** C ******************************* C ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISACNC=ISACNA IF(IFILWD.EQ.2.OR.IFILWD.EQ.3)ISACNC=ISTRI2 C IOUNIT=ISACNU IFILE=ISACNA IF(IFILWD.EQ.2.OR.IFILWD.EQ.3)IFILE=ISTRI2 ISTAT=ISACST IFORM=ISACFO IACCES=ISACAC IPROT=ISACPR ICURST=ISACCS C ISUBN0='SACO' IERRFI='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SACO')GOTO1299 WRITE(ICOUT,1293)IOUNIT 1293 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1294)IFILE 1294 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1295)ISTAT,IFORM,IACCES,IPROT,ICURST 1295 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 1A12,2X,A12,2X,A12,2X,A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1296)ISUBN0,IERRFI 1296 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 1299 CONTINUE C C *********************************************************** C ** STEP 13-- ** C ** CHECK TO SEE IF THE SAVE-CONCLUSIONS FILE MAY EXIST ** C *********************************************************** C ISTEPN='13' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ISTAT.EQ.'NONE')GOTO1300 GOTO1390 1300 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** IMPLEMENTATION ERROR IN DPSACO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE DESIRED SAVING OF COMMANDS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1313) 1313 FORMAT(' CANNOT BE CARRIED OUT BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1314) 1314 FORMAT(' THE INTERNAL VARIABLE ISACST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT(' WHICH ALLOWS SUCH COMMAND-SAVINGING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316) 1316 FORMAT(' HAS BEEN SET TO NONE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1317)ISTAT,ISACST 1317 FORMAT('ISTAT,ISACST = ',A12,2X,A12) CALL DPWRST('XXX','BUG ') GOTO9000 1390 CONTINUE C C ********************************************************* C ** STEP 21-- ** C ** FROM THE RECALL-LIST OF THE PREVIOUS 30 COMMANDS, ** C ** STRIP OUT THE DESIRED COMMAND LINE NUMBERS ** C ** THE LIST THAT THE ANALYST HAS SPECIFIED ** C ** SHOULD BE IN THE ORDER THAT THE ANALYST ** C ** WANTS THE COMMANDS EXECUTED ** C ** (USUALLY--BUT NOT NECESSARILY--IT IS FROM LARGEST ** C ** (MOST DISTANT) TO SMALLEST (MOST RECENT)) ** C ********************************************************* C CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 CCCCC MAXTAB=IREPMX MAXTAB=MAXLIS MININT=1 CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 CCCCC MAXINT=IREPMX MAXINT=MAXLIS ISTART=ISTAM1+1 ISTOP=NUMARG IF(ISTART.GT.ISTOP)GOTO2110 GOTO2120 C 2110 CONTINUE I=1 ITAB(I)=1 NTAB=I GOTO2190 C 2120 CONTINUE CALL DPEXIN(IHARG,IARGT,IARG,NUMARG,ISTART,ISTOP, 1MININT,MAXINT, 1ITAB,NTAB,MAXTAB, 1IBUGS2,ISUBRO,IERROR) GOTO2190 C 2190 CONTINUE C C ************************** C ** STEP 31-- ** C ** OPEN THE FILE ** C ************************** C ISTEPN='31' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 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 3190 CONTINUE C C ****************************************************** C ** STEP 41-- ** C ** PRINT OUT THE SPECIFIED COMMANDS ** C ** (BOTH TO SCREEN AND TO FILE) ** C ** IN ORDER OF EXECUTION ** C ****************************************************** C ISTEPN='41' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFEEDB.EQ.'OFF')GOTO4109 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4101) 4101 FORMAT('THE SAVED COMMAND LINES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 4109 CONTINUE C DO4110I=1,NTAB I2=ITAB(I) CCCCC I3=IPOINT-I2-1 I3=IPOINT-I2 CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 CCCCC IF(I3.LE.0)I3=I3+IREPMX IF(I3.LE.0)I3=I3+MAXLIS DO4120J=1,80 IC1=IANSSV(I3,J) ISTRIN(J:J)=IC1 4120 CONTINUE WRITE(IOUNIT,4125)(ISTRIN(J:J),J=1,80) 4125 FORMAT(80A1) IF(IFEEDB.EQ.'OFF')GOTO4129 CALL DPDB80(ISTRIN,J2MAX,IBUGS2,ISUBRO,IERROR) WRITE(ICOUT,4126)I2,(ISTRIN(J:J),J=1,J2MAX) 4126 FORMAT(4X,I2,'--',80A1) CALL DPWRST('XXX','BUG ') 4129 CONTINUE 4110 CONTINUE C C ************************** C ** STEP 51-- ** C ** CLOSE THE FILE ** C ************************** C ISTEPN='51' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IENDFI='OFF' IREWIN='OFF' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) C 5190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SACO')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPSACO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGS2,ISUBRO,IFOUND,IERROR 9012 FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IWIDTH 9013 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,9014)(IANSLC(I),I=1,IWIDTH) 9014 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMARG 9015 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO9018 DO9016I=1,NUMARG WRITE(ICOUT,9017)I,IHARG(I) 9017 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9016 CONTINUE 9018 CONTINUE CCCCC THE FOLLOWING 2 LINES WERE CHANGED APRIL 1993 CCCCC WRITE(ICOUT,9021)IREPMX,IPOINT C9021 FORMAT('IREPMX,IPOINT = ',I8,2X,I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)MAXLIS,IPOINT 9021 FORMAT('MAXLIS,IPOINT = ',I8,2X,I8) CALL DPWRST('XXX','BUG ') DO9022J=1,IREPMX WRITE(ICOUT,9023)J,(IANSSV(J,I),I=1,80) 9023 FORMAT('J,(IANSSV(J,I),I=1,80) = ',I8,2X,80A1) CALL DPWRST('XXX','BUG ') 9022 CONTINUE WRITE(ICOUT,9041)IOUNIT 9041 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)IFILE 9042 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)ISTAT 9043 FORMAT('ISTAT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)IFORM 9044 FORMAT('IFORM = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9045)IACCES 9045 FORMAT('IACCES = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9046)IPROT 9046 FORMAT('IPROT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9047)ICURST 9047 FORMAT('ICURST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9048)IENDFI 9048 FORMAT('IENDFI = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9049)IREWIN 9049 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,9061)IFILWD,ISTAM1 9061 FORMAT('IFILWD,ISTAM1 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9062)ISTART,ISTOP 9062 FORMAT('ISTART,ISTOP = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9063)MININT,MAXINT 9063 FORMAT('MININT,MAXINT = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9071)NTAB,MAXTAB 9071 FORMAT('NTAB,MAXTAB = ',2I8) CALL DPWRST('XXX','BUG ') IF(NTAB.LE.0)GOTO9079 DO9072I=1,NTAB WRITE(ICOUT,9073)I,ITAB(I) 9073 FORMAT('I,ITAB(I) = ',2I8) CALL DPWRST('XXX','BUG ') 9072 CONTINUE 9079 CONTINUE WRITE(ICOUT,9081)ISACNC 9081 FORMAT('ISACNC = ',A80) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSAPC(IBUGS2,ISUBRO,IFOUND,IERROR) C C PURPOSE--GUI SAVE PLOT CONTROL (= LIST OUT PLOT CONTROL C SETTINGS TO SCREEN SO TCL/TK CAN READ THEM. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--97/11 C ORIGINAL VERSION--NOVEMBER 1997. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGS2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C CHARACTER*4 ITEMP CHARACTER*4 ITITFL CHARACTER*4 ILABFL CHARACTER*4 ILEGFL CHARACTER*4 ILINFL CHARACTER*4 ICHAFL CHARACTER*4 ISPIFL CHARACTER*4 IBARFL CHARACTER*4 IBACFL CHARACTER*4 ILIMFL C CHARACTER*4 ITMP1 CHARACTER*4 ITMP2 CHARACTER*4 ITMP3 CHARACTER*4 ITMP4 C CHARACTER*4 ITEMPH(10) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOHK.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='DPSA' ISUBN2='PC ' C IFOUND='YES' IERROR='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAPC')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSAPC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR 53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IWIDTH 54 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,55)(IANSLC(I),I=1,IWIDTH) 55 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 90 CONTINUE C ISTART=1 ISTOP=100 ITITFL='OFF' ILABFL='OFF' ILEGFL='OFF' ILINFL='OFF' ICHAFL='OFF' ISPIFL='OFF' IBARFL='OFF' IBACFL='OFF' ILIMFL='OFF' C IJUNK1=NUMARG IJUNK2=NUMARG-1 IJUNK3=NUMARG-2 IF(NUMARG.GE.2.AND.IARGT(IJUNK1).EQ.'NUMB'.AND. 1 IARGT(IJUNK2).EQ.'NUMB')THEN ISTART=IARG(IJUNK2) ISTOP=IARG(IJUNK1) IF(ISTART.LT.1)ISTART=1 IF(ISTOP.GT.100)ISTOP=100 IF(ISTART.GT.ISTOP)THEN IJUNK4=ISTOP ISTOP=ISTART ISTART=IJUNK4 ENDIF ELSEIF(NUMARG.GE.2.AND.IARGT(IJUNK1).EQ.'NUMB'.AND. 1 IARGT(IJUNK2).NE.'NUMB')THEN ISTART=1 ISTOP=IARG(IJUNK1) IF(ISTOP.GT.100)ISTOP=100 IJUNK3=IJUNK2 ELSE IJUNK3=IJUNK1 ENDIF C IF(IJUNK3.GE.1)THEN ITEMP=IHARG(IJUNK3) IF(ITEMP.EQ.'TITL')ITITFL='ON' IF(ITEMP.EQ.'LABE')ILABFL='ON' IF(ITEMP.EQ.'LEGE')ILEGFL='ON' IF(ITEMP.EQ.'LINE')ILINFL='ON' IF(ITEMP.EQ.'CHAR')ICHAFL='ON' IF(ITEMP.EQ.'SPIK')ISPIFL='ON' IF(ITEMP.EQ.'BAR ')IBARFL='ON' IF(ITEMP.EQ.'BACK')IBACFL='ON' IF(ITEMP.EQ.'LIMI')ILIMFL='ON' IF(ITEMP.EQ.'ALL ')THEN ITITFL='ON' ILABFL='ON' ILEGFL='ON' ILINFL='ON' ICHAFL='ON' ISPIFL='ON' IBARFL='ON' IBACFL='ON' ILIMFL='ON' ENDIF ENDIF C LINC=5 C C ****************************************************** C ** STEP 41-- C ** WRITE OUT TO THE SAVE FILE; C ****************************************************** C ISTEPN='41' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C -----WRITE OUT COMMON FOR PLOT CONTROL----- C IF(IBACFL.EQ.'OFF')GOTO199 WRITE(ICOUT,101)IBACCO 101 FORMAT('BACKGROUND COLOR = ',A4) CALL DPWRST('XXX','BUG ') 199 CONTINUE C IF(ITITFL.EQ.'OFF')GOTO299 WRITE(ICOUT,201) 201 FORMAT('TITLE ATTRIBUTES') CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,202)(ITITTE(I)(1:1),I=1,MIN(NCTITL,130)) 202 FORMAT(' TITLE = ',130A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)ITITFO 203 FORMAT(' TITLE FONT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,204)ITITCA 204 FORMAT(' TITLE CASE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,205)ITITFI 205 FORMAT(' TITLE FILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,206)ITITCO 206 FORMAT(' TITLE COLOR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,207)PTITHE 207 FORMAT(' TITLE SIZE = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,208)PTITTH 208 FORMAT(' TITLE THICKNESS = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,209)PTITDS 209 FORMAT(' TITLE DISPLACEMENT = ',E12.5) CALL DPWRST('XXX','BUG ') 299 CONTINUE C IF(ILABFL.EQ.'OFF')GOTO399 WRITE(ICOUT,301) 301 FORMAT('AXIS LABEL ATTRIBUTES') CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,311)(IX1LTE(I)(1:1),I=1,NCX1LA) 311 FORMAT(' X1LABEL = ',130A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)(IX2LTE(I)(1:1),I=1,NCX2LA) 312 FORMAT(' X2LABEL = ',130A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313)(IX3LTE(I)(1:1),I=1,NCX3LA) 313 FORMAT(' X3LABEL = ',130A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314)(IY1LTE(I)(1:1),I=1,NCY1LA) 314 FORMAT(' Y1LABEL = ',130A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)(IY2LTE(I)(1:1),I=1,NCY2LA) 315 FORMAT(' Y2LABEL = ',130A1) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,321)IX1LFO 321 FORMAT(' X1LABEL FONT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,322)IX1LCA 322 FORMAT(' X1LABEL CASE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)IX1LFI 323 FORMAT(' X1LABEL FILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,324)IX1LCO 324 FORMAT(' X1LABEL COLOR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325)PX1LDS 325 FORMAT(' X1LABEL DISPLACEMENT = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,326)PX1LHE 326 FORMAT(' X1LABEL SIZE = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,327)PX1LTH 327 FORMAT(' X1LABEL THICKNESS = ',E12.5) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,331)IX2LFO 331 FORMAT(' X2LABEL FONT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,332)IX2LCA 332 FORMAT(' X2LABEL CASE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,333)IX2LFI 333 FORMAT(' X2LABEL FILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,334)IX2LCO 334 FORMAT(' X2LABEL COLOR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,335)PX2LDS 335 FORMAT(' X2LABEL DISPLACEMENT = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,336)PX2LHE 336 FORMAT(' X2LABEL SIZE = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,337)PX2LTH 337 FORMAT(' X2LABEL THICKNESS = ',E12.5) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,341)IX3LFO 341 FORMAT(' X3LABEL FONT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,342)IX3LCA 342 FORMAT(' X3LABEL CASE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,343)IX3LFI 343 FORMAT(' X3LABEL FILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,344)IX3LCO 344 FORMAT(' X3LABEL COLOR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,345)PX3LDS 345 FORMAT(' X3LABEL DISPLACEMENT = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,346)PX3LHE 346 FORMAT(' X3LABEL SIZE = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,347)PX3LTH 347 FORMAT(' X3LABEL THICKNESS = ',E12.5) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,351)IY1LFO 351 FORMAT(' Y1LABEL FONT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,352)IY1LCA 352 FORMAT(' Y1LABEL CASE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,353)IY1LFI 353 FORMAT(' Y1LABEL FILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,354)IY1LCO 354 FORMAT(' Y1LABEL COLOR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,355)PY1LDS 355 FORMAT(' Y1LABEL DISPLACEMENT = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,356)PY1LHE 356 FORMAT(' Y1LABEL SIZE = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,357)PY1LTH 357 FORMAT(' Y1LABEL THICKNESS = ',E12.5) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,361)IY2LFO 361 FORMAT(' Y2LABEL FONT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,362)IY2LCA 362 FORMAT(' Y2LABEL CASE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,363)IY2LFI 363 FORMAT(' Y2LABEL FILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,364)IY2LCO 364 FORMAT(' Y2LABEL COLOR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,365)PY2LDS 365 FORMAT(' Y2LABEL DISPLACEMENT = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,366)PY2LHE 366 FORMAT(' Y2LABEL SIZE = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,367)PY2LTH 367 FORMAT(' Y2LABEL THICKNESS = ',E12.5) CALL DPWRST('XXX','BUG ') 399 CONTINUE C IF(ILEGFL.EQ.'OFF')GOTO499 WRITE(ICOUT,401) 401 FORMAT('LEGEND ATTRIBUTES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402)NUMLEG 402 FORMAT(' NUMBER OF CURRENTLY DEFINED LEGENDS = ',I10) CALL DPWRST('XXX','BUG ') C DO491LL=1,20 LSTRT=(LL-1)*LINC+1 LSTOP=LL*LINC IF(LSTRT.GT.NUMLEG)GOTO498 IF(LSTOP.GT.NUMLEG)LSTOP=NUMLEG C DO490L=LSTRT,LSTOP ISTRT=ILEGST(L) ISTP=ILEGSP(L) IF(ISTP-ISTRT+1.GT.80)ISTP=ISTRT+79 WRITE(ICOUT,411)L,L,(ILEGTE(J)(1:1),J=ISTRT,ISTP) 411 FORMAT(' LEGEND ',2I5,' = ',80A1) CALL DPWRST('XXX','BUG ') 490 CONTINUE 491 CONTINUE 498 CONTINUE C DO492LL=1,20 LSTRT=(LL-1)*LINC+1 LSTOP=LL*LINC IF(LSTRT.GT.ISTOP)GOTO492 IF(LSTRT.LT.ISTART)LSTRT=ISTART IF(LSTOP.GT.ISTOP)LSTOP=ISTOP C WRITE(ICOUT,412)LSTRT,LSTOP,(ILEGFO(I),I=LSTRT,LSTOP) 412 FORMAT(' LEGEND FONT ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413)LSTRT,LSTOP,(ILEGCA(I),I=LSTRT,LSTOP) 413 FORMAT(' LEGEND CASE ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,414)LSTRT,LSTOP,(ILEGJU(I),I=LSTRT,LSTOP) 414 FORMAT(' LEGEND JUSTIFICATION ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,415)LSTRT,LSTOP,(ILEGDI(I),I=LSTRT,LSTOP) 415 FORMAT(' LEGEND DIRECTION ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,416)LSTRT,LSTOP,(ILEGFI(I),I=LSTRT,LSTOP) 416 FORMAT(' LEGEND FILL ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417)LSTRT,LSTOP,(ILEGCO(I),I=LSTRT,LSTOP) 417 FORMAT(' LEGEND COLOR ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') C DO1418I=LSTRT,LSTOP WRITE(ICOUT,418)I,I,PLEGXC(I),PLEGYC(I) 418 FORMAT(' LEGEND COORDINATES ',I5,1X,I5,' = ',2(E12.5,1X)) CALL DPWRST('XXX','BUG ') 1418 CONTINUE C WRITE(ICOUT,419)LSTRT,LSTOP,(PLEGHE(I),I=LSTRT,LSTOP) 419 FORMAT(' LEGEND SIZE ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,420)LSTRT,LSTOP,(PLEGWI(I),I=LSTRT,LSTOP) 420 FORMAT(' LEGEND WIDTH ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,421)LSTRT,LSTOP,(PLEGTH(I),I=LSTRT,LSTOP) 421 FORMAT(' LEGEND THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,422)LSTRT,LSTOP,(ALEGAN(I),I=LSTRT,LSTOP) 422 FORMAT(' LEGEND ANGLE ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') 492 CONTINUE C 499 CONTINUE C DO1990LL=1,20 LSTRT=(LL-1)*LINC+1 LSTOP=LL*LINC IF(LSTRT.GT.ISTOP)GOTO1999 IF(LSTRT.LT.ISTART)LSTRT=ISTART IF(LSTOP.GT.ISTOP)LSTOP=ISTOP C IF(ILINFL.EQ.'OFF')GOTO599 CCCCC WRITE(ICOUT,501) CC501 FORMAT('LINE ATTRIBUTES') CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,512)LSTRT,LSTOP,(ILINPA(I),I=LSTRT,LSTOP) 512 FORMAT(' LINE ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,513)LSTRT,LSTOP,(ILINCO(I),I=LSTRT,LSTOP) 513 FORMAT(' LINE COLOR ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,514)LSTRT,LSTOP,(PLINTH(I),I=LSTRT,LSTOP) 514 FORMAT(' LINE THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') 590 CONTINUE 599 CONTINUE C IF(ICHAFL.EQ.'OFF')GOTO699 CCCCC WRITE(ICOUT,601) CC601 FORMAT('CHARACTER ATTRIBUTES') CCCCC CALL DPWRST('XXX','BUG ') ICOUNT=0 DO601I=LSTRT,LSTOP ICOUNT=ICOUNT+1 ITEMPH(ICOUNT)='BLAN' IF(ICHAPA(I).NE.' ')ITEMPH(ICOUNT)=ICHAPA(I) 601 CONTINUE C WRITE(ICOUT,611)LSTRT,LSTOP,(ITEMPH(I),I=1,ICOUNT) 611 FORMAT(' CHARACTER ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,612)LSTRT,LSTOP,(ICHAFO(I),I=LSTRT,LSTOP) 612 FORMAT(' CHARACTER FONT ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,613)LSTRT,LSTOP,(ICHACO(I),I=LSTRT,LSTOP) 613 FORMAT(' CHARACTER COLOR ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,614)LSTRT,LSTOP,(ICHACA(I),I=LSTRT,LSTOP) 614 FORMAT(' CHARACTER CASE ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,615)LSTRT,LSTOP,(ICHAJU(I),I=LSTRT,LSTOP) 615 FORMAT(' CHARACTER JUSTIFICATION ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,616)LSTRT,LSTOP,(ICHADI(I),I=LSTRT,LSTOP) 616 FORMAT(' CHARACTER DIRECTION ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,617)LSTRT,LSTOP,(ICHAFI(I),I=LSTRT,LSTOP) 617 FORMAT(' CHARACTER FILL ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,618)LSTRT,LSTOP,(PCHAHE(I),I=LSTRT,LSTOP) 618 FORMAT(' CHARACTER SIZE ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,619)LSTRT,LSTOP,(PCHAWI(I),I=LSTRT,LSTOP) 619 FORMAT(' CHARACTER WIDTH ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,620)LSTRT,LSTOP,(ACHAAN(I),I=LSTRT,LSTOP) 620 FORMAT(' CHARACTER ANGLE ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,621)LSTRT,LSTOP,(PCHATH(I),I=LSTRT,LSTOP) 621 FORMAT(' CHARACTER THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') 690 CONTINUE 699 CONTINUE C IF(ISPIFL.EQ.'OFF')GOTO799 CCCCC WRITE(ICOUT,701) CC701 FORMAT('SPIKE ATTRIBUTES') CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,711)LSTRT,LSTOP,(ISPISW(I),I=LSTRT,LSTOP) 711 FORMAT(' SPIKE ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,712)LSTRT,LSTOP,(ISPILI(I),I=LSTRT,LSTOP) 712 FORMAT(' SPIKE LINE ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,713)LSTRT,LSTOP,(ISPICO(I),I=LSTRT,LSTOP) 713 FORMAT(' SPIKE COLOR ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,714)LSTRT,LSTOP,(PSPITH(I),I=LSTRT,LSTOP) 714 FORMAT(' SPIKE THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,715)LSTRT,LSTOP,(ASPIBA(I),I=LSTRT,LSTOP) 715 FORMAT(' SPIKE BASE ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') 790 CONTINUE 799 CONTINUE C IF(IBARFL.EQ.'OFF')GOTO899 CCCCC WRITE(ICOUT,801) CC801 FORMAT('BAR ATTRIBUTES') CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)LSTRT,LSTOP,(IBARSW(I),I=LSTRT,LSTOP) 811 FORMAT(' BAR ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,812)LSTRT,LSTOP,(ABARBA(I),I=LSTRT,LSTOP) 812 FORMAT(' BAR BASE ',I5,1X,I5,' ',' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,813)LSTRT,LSTOP,(ABARWI(I),I=LSTRT,LSTOP) 813 FORMAT(' BAR WIDTH ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,821)LSTRT,LSTOP,(IBABLI(I),I=LSTRT,LSTOP) 821 FORMAT(' BAR BORDER LINE ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,822)LSTRT,LSTOP,(IBABCO(I),I=LSTRT,LSTOP) 822 FORMAT(' BAR BORDER COLOR ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,823)LSTRT,LSTOP,(PBABTH(I),I=LSTRT,LSTOP) 823 FORMAT(' BAR BORDER THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,831)LSTRT,LSTOP,(IBAFSW(I),I=LSTRT,LSTOP) 831 FORMAT(' BAR FILL ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,832)LSTRT,LSTOP,(IBAFCO(I),I=LSTRT,LSTOP) 832 FORMAT(' BAR FILL COLOR ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,841)LSTRT,LSTOP,(IBAPTY(I),I=LSTRT,LSTOP) 841 FORMAT(' BAR PATTERN ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,842)LSTRT,LSTOP,(IBAPLI(I),I=LSTRT,LSTOP) 842 FORMAT(' BAR PATTERN LINE ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,843)LSTRT,LSTOP,(IBAPCO(I),I=LSTRT,LSTOP) 843 FORMAT(' BAR PATTERN COLOR ',I5,1X,I5,' = ',10(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,844)LSTRT,LSTOP,(PBABTH(I),I=LSTRT,LSTOP) 844 FORMAT(' BAR PATTERN THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,845)LSTRT,LSTOP,(PBAPSP(I),I=LSTRT,LSTOP) 845 FORMAT(' BAR PATTERN SPACING ',I5,1X,I5,' = ',10(E12.5,1X)) CALL DPWRST('XXX','BUG ') 890 CONTINUE 899 CONTINUE C 1990 CONTINUE 1999 CONTINUE C IF(ILIMFL.EQ.'OFF')GOTO990 WRITE(ICOUT,901) 901 FORMAT('LIMIT AND TIC MARK ATTRIBUTES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902)FX1MNZ,FX1MXZ 902 FORMAT(' X1 LIMITS = ',E12.5,1X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,904)FX2MNZ,FX2MXZ 904 FORMAT(' X2 LIMITS = ',E12.5,1X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,906)FY1MNZ,FY1MXZ 906 FORMAT(' Y1 LIMITS = ',E12.5,1X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,908)FY2MNZ,FY2MXZ 908 FORMAT(' Y2 LIMITS = ',E12.5,1X,E15.7) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,911)IX1FSW,IX2FSW,IY1FSW,IY2FSW 911 FORMAT(' X1, X2, Y1, Y2 FRAME = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1911)IX1FPA,IX2FPA,IY1FPA,IY2FPA 1911 FORMAT(' X1, X2, Y1, Y2 FRAME PATTERN = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1912)IX1FCO,IX2FCO,IY1FCO,IY2FCO 1912 FORMAT(' X1, X2, Y1, Y2 FRAME COLOR = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1913)PFRATH 1913 FORMAT(' FRAME THICKNESS = ',E12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1915)PXMIN,PXMAX,PYMIN,PYMAX 1915 FORMAT(' FRAME COORDINATES = ',4E12.5) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,912)IVGRSW,IHGRSW 912 FORMAT(' X, Y GRID = ',2(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,913)IVGRPA,IHGRPA 913 FORMAT(' X, Y GRID PATTERN = ',2(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,914)IVGRCO,IHGRCO 914 FORMAT(' X, Y GRID COLOR = ',2(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,915)PVGRTH,PHGRTH 915 FORMAT(' X, Y GRID THICKNESS = ',2(E12.5,1X)) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,921)IX1TSW,IX2TSW,IY1TSW,IY2TSW 921 FORMAT(' X1, X2, Y1, Y2 TIC = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,922)IX1TJU,IX2TJU,IY1TJU,IY2TJU 922 FORMAT(' X1, X2, Y1, Y2 TIC POSITION = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,923)IX1TCO,IX2TCO,IY1TCO,IY2TCO 923 FORMAT(' X1, X2, Y1, Y2 TIC COLOR = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,924)PX1TLE,PX2TLE,PY1TLE,PY2TLE 924 FORMAT(' X1, X2, Y1, Y2 TIC SIZE = ',4(E12.5,1X)) CALL DPWRST('XXX','BUG ') ITMP1='OFF' ITMP2='OFF' ITMP3='OFF' ITMP4='OFF' IF(IX1TSC.EQ.'LOG')ITMP1='ON' IF(IX2TSC.EQ.'LOG')ITMP2='ON' IF(IY1TSC.EQ.'LOG')ITMP3='ON' IF(IY2TSC.EQ.'LOG')ITMP4='ON' WRITE(ICOUT,925)ITMP1,ITMP2,ITMP3,ITMP4 925 FORMAT(' X1, X2, Y1, Y2 LOG = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,931)PX1TOL,PX1TOR 931 FORMAT(' X1 TIC OFFSET = ',2(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,932)PX2TOL,PX2TOR 932 FORMAT(' X2 TIC OFFSET = ',2(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,933)PY1TOB,PY1TOT 933 FORMAT(' Y1 TIC OFFSET = ',2(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,934)PY2TOB,PY2TOT 934 FORMAT(' Y2 TIC OFFSET = ',2(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,935)ITICUN 935 FORMAT(' TIC OFFSET UNITS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,941)NMJX1T,NMJX2T,NMJY1T,NMJY2T 941 FORMAT(' X1, X2, Y1, Y2 TIC NUMBER MAJOR = ',4(I5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,942)NMNX1T,NMNX2T,NMNY1T,NMNY2T 942 FORMAT(' X1, X2, Y1, Y2 TIC NUMBER MINOR = ',4(I5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,951)IX1ZSW,IX2ZSW,IY1ZSW,IY2ZSW 951 FORMAT(' X1, X2, Y1, Y2 TIC LABEL = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,952)IX1ZCO,IX2ZCO,IY1ZCO,IY2ZCO 952 FORMAT(' X1, X2, Y1, Y2 TIC LABEL COLOR = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,953)IX1ZCA,IX2ZCA,IY1ZCA,IY2ZCA 953 FORMAT(' X1, X2, Y1, Y2 TIC LABEL CASE = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,954)IX1ZFO,IX2ZFO,IY1ZFO,IY2ZFO 954 FORMAT(' X1, X2, Y1, Y2 TIC LABEL FONT = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,955)IX1ZJU,IX2ZJU,IY1ZJU,IY2ZJU 955 FORMAT(' X1, X2, Y1, Y2 TIC LABEL JUSTIFICATION = ', 14(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,956)IX1ZDI,IX2ZDI,IY1ZDI,IY2ZDI 956 FORMAT(' X1, X2, Y1, Y2 TIC LABEL DIRECTION = ', 14(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,957)IX1ZFI,IX2ZFI,IY1ZFI,IY2ZFI 957 FORMAT(' X1, X2, Y1, Y2 TIC LABEL FILL = ',4(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,958)IX1ZDP,IX2ZDP,IY1ZDP,IY2ZDP 958 FORMAT(' X1, X2, Y1, Y2 TIC LABEL DECIMALS = ',4(I5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,959)PX1ZDS,PX2ZDS,PY1ZDS,PY2ZDS 959 FORMAT(' X1, X2, Y1, Y2 TIC LABEL DISPLACEMENT = ', 14(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,960)AX1ZAN,AX2ZAN,AY1ZAN,AY2ZAN 960 FORMAT(' X1, X2, Y1, Y2 TIC LABEL ANGLE = ',4(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,961)PX1ZHE,PX2ZHE,PY1ZHE,PY2ZHE 961 FORMAT(' X1, X2, Y1, Y2 TIC LABEL SIZE = ',4(E12.5,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,971)PTIZTH 971 FORMAT(' TIC LABEL THICKNESS = ',4(E12.5,1X)) CALL DPWRST('XXX','BUG ') C 990 CONTINUE C C -----END WRITING OUT----------------------- C C *************************** C ** STEP 42-- ** C ** WRITE OUT A MESSAGE ** C *************************** C ISTEPN='42' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSAPL(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG, 1IBUGS2,ISUBRO,IFOUND,IERROR) C C PURPOSE--SAVE (FOR FUTURE USE BY THE REPEAT GRAPH COMMAND) C SELECTED PLOTS. IT SUPPORTS THE FOLLOWING: C C SAVE PLOT : C SAVES THE CURRENT PIXMAP TO THE SPECIFIED FILE C SAVE PLOT AUTOMATIC : C AUTOMATICALLY SAVE ALL SUBSEQUENT FILES, USING C AS THE BASE FILE NAME (APPEND A C ".1", ".2", ETC.) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGU C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--97/4 C ORIGINAL VERSION--APRIL 1997. C UPDATED --AUGUST 1997. MOVE SOME CODE TO A LOWER LEVEL C TO SUPPORT NON-X11 DEVICES C (SPECIFICALLY PC FOR NOW) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C INCLUDE 'DPCOPA.INC' CHARACTER*4 IANSLC CHARACTER*4 IHARG CHARACTER*4 IARGT CCCCC CHARACTER*1 IANSSV CCCCC CHARACTER*80 ISACNC C CHARACTER*4 IBUGS2 CHARACTER*4 ISUBRO CHARACTER*4 IERROR CHARACTER*4 IFOUND C CHARACTER*4 IC4 CHARACTER*4 ICODE C DIMENSION FOLLOWING 2 LINES TO MAXSTR CHARACTER*256 ISTRIN CHARACTER*256 ISTRI2 CHARACTER*128 CTEMP C CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C CHARACTER*4 ISAVFL C DIMENSION IANSLC(*) DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) CCCCC DIMENSION IADE(128) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPM.INC' 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='DPSA' ISUBN2='PL ' C IFOUND='NO' IERROR='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAPL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPSAPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGS2,ISUBRO,IFOUND,IERROR 52 FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IWIDTH 53 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,54)(IANSLC(I),I=1,IWIDTH) 54 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)NUMARG 55 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO58 DO56I=1,NUMARG WRITE(ICOUT,57)I,IHARG(I) 57 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 56 CONTINUE 58 CONTINUE CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFOUND='YES' C C ****************************************************** C ** STEP 10-- ** C ** DETERMINE IF HAVE SAVE PLOT AUTOMATIC CASE ** C ****************************************************** C ISTEPN='10' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISAVFL='OFF' IF(NUMARG.GE.1)THEN DO1010I=1,NUMARG IF(IHARG(I).EQ.'AUTO' .OR. IHARG(I).EQ.'ON' .OR. 1 IHARG(I).EQ.'YES' )THEN ISAVFL='ON' IPXMFL='ON' GOTO1019 ENDIF 1010 CONTINUE 1019 CONTINUE ENDIF C C ****************************************************** C ** STEP 11-- ** C ** DETERMINE IF HAVE AN EXPLICIT FILE REFERENCE ** C ** WHERE THE PIXMAPS WILL BE SAVED, OR WILL THEY ** C ** BE SAVED IN THE DEFAULT FILE (PIXMAP.? ** C ****************************************************** C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFILWD=(-999) C DO1100I=1,MAXSTR IC4=IANSLC(I) ISTRIN(I:I)=IC4(1:1) 1100 CONTINUE C IWORD=1 ISTART=1 ISTOP=MAXSTR-1 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,ISTRI2,NCSTR2, 1IBUGS2,ISUBRO,IERROR) C IF(NUMARG.LE.0)GOTO1129 IWORD=2 ISTART=1 ISTOP=MAXSTR-1 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,ISTRI2,NCSTR2, 1IBUGS2,ISUBRO,IERROR) IF(NCSTR2.LE.0)GOTO1129 DO1121I=1,NCSTR2 IF(ISTRI2(I:I).EQ.'.')GOTO1122 1121 CONTINUE GOTO1129 1122 CONTINUE IFILWD=2 GOTO1190 1129 CONTINUE C IF(NUMARG.LE.1)GOTO1139 IWORD=3 ISTART=1 ISTOP=MAXSTR-1 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,ISTRI2,NCSTR2, 1IBUGS2,ISUBRO,IERROR) IF(NCSTR2.LE.0)GOTO1139 DO1131I=1,NCSTR2 IF(ISTRI2(I:I).EQ.'.')GOTO1132 1131 CONTINUE GOTO1139 1132 CONTINUE IFILWD=3 GOTO1190 1139 CONTINUE C IF(NUMARG.LE.2)GOTO1149 IWORD=4 ISTART=1 ISTOP=MAXSTR-1 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,ISTRI2,NCSTR2, 1IBUGS2,ISUBRO,IERROR) IF(NCSTR2.LE.0)GOTO1149 DO1141I=1,NCSTR2 IF(ISTRI2(I:I).EQ.'.')GOTO1142 1141 CONTINUE GOTO1149 1142 CONTINUE IFILWD=4 GOTO1190 1149 CONTINUE C 1190 CONTINUE C IF(ISAVFL.EQ.'ON')THEN IF(IFILWD.GE.1)THEN IPXMFB=' ' IPXMFB(1:NCSTR2)=ISTRI2(1:NCSTR2) IPXMNC=NCSTR2 ENDIF IF(IHARG(NUMARG).EQ.'OFF'.OR.IHARG(NUMARG).EQ.'DEFA'.OR. 1 IHARG(NUMARG).EQ.'NO')THEN ISAVFL='OFF' ENDIF GOTO9000 ENDIF C NUMPXM=NUMPXM+1 IF(NUMPXM.GT.MAXPM)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1191)MAXPM CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 1191 FORMAT('***** ERROR IN DPSAPL: MAXIMUM NUMBER OF PIXMAPS (',I5, 1') EXCEEDED.') C IF(IFILWD.LE.0)THEN ISTRI2=' ' ISTRI2(1:7)='pixmap.' IF(NUMPXM.LE.9)THEN WRITE(ISTRI2(8:8),'(I1)')NUMPXM NCSTR2=8 ELSEIF(NUMPXM.LE.99)THEN WRITE(ISTRI2(8:9),'(I2)')NUMPXM NCSTR2=9 ELSEIF(NUMPXM.LE.999)THEN WRITE(ISTRI2(8:10),'(I3)')NUMPXM NCSTR2=10 ENDIF ENDIF IPXMFN(NUMPXM)=' ' IPXMFN(NUMPXM)(1:128)=ISTRI2(1:128) IF(IPXMCM(NUMPXM).EQ.' ')THEN IPXMCM(NUMPXM)(1:128)=IPXMFN(NUMPXM)(1:128) ENDIF C C ******************************* C ** STEP 12-- ** C ** CALL XSAVEG ** C ******************************* C ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NCSTR2.GT.127)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1209 FORMAT('***** ERROR IN DPSAPL--FILE NAME EXCEEDS 127 ', 1'CHARACTERS.') ENDIF c C AUGUST 1997. TO MAKE CODE MORE GENERAL, CALL A LOW LEVEL C GRAPHICS ROUTINE. MOVE THIS CODE TO THAT SUBROUTINE. C ICODE='SAVE' CTEMP=' ' NCTEMP=0 CALL GRSAGR(ICODE,ISTRI2,NCSTR2,CTEMP,NCTEMP) C CCCCC DO1220I=1,NCSTR2 CCCCC CALL DPCOAN(ISTRI2(I:I),IJUNK) CCCCC IADE(I)=IJUNK C1220 CONTINUE CCCCC IADE(NCSTR2+1)=0 C CCCCC IERR=0 CCCCC CALL XSAVEG(IADE,IERR) CCCCC IF(IERR.EQ.1)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1251) CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 C1251 FORMAT('***** ERROR IN DPSAPL--WRITING BIT MAP UNSUCCESSFUL.') CCCCC ELSEIF(IERR.EQ.2)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1261) CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 C1261 FORMAT('***** ERROR IN DPSAPL--NO CURRENT PIXMAP TO SAVE.') CCCCC ELSEIF(IERR.EQ.3)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1271) CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 C1271 FORMAT('***** ERROR IN DPSAPL--X11 HAS NOT BEEN OPENED.') CCCCC ELSEIF(IERR.EQ.4)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1281) CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 C1281 FORMAT('***** ERROR IN DPSAPL--X11 NOT INSTALLED ON THIS ', CCCCC1'IMPLEMENTATION.') CCCCC ELSE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1291) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1292)ISTRI2(1:NCSTR2) CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 C1291 FORMAT('***** CURRENT PIXMAP SUCCESSFULLY SAVED TO FILE ') C1292 FORMAT(' ',A128) CCCCC ENDIF C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAPL')GOTO1299 WRITE(ICOUT,1293)ISTRI2(1:NCSTR2) 1293 FORMAT('ISTRI2 = ',A128) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1294)NCSTR2 1294 FORMAT('NCSTR2 = ',I4) CALL DPWRST('XXX','BUG ') 1299 CONTINUE C 5190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAPL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPSAPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGS2,ISUBRO,IFOUND,IERROR 9012 FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IWIDTH 9013 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,9014)(IANSLC(I),I=1,IWIDTH) 9014 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMARG 9015 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO9018 DO9016I=1,NUMARG WRITE(ICOUT,9017)I,IHARG(I) 9017 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9016 CONTINUE 9018 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSAVE(IFOUND,IERROR) C C PURPOSE--SAVE (= WRITE OUT TO FILE) ALL INTERNAL DATAPLOT C SETTINGS. THE MASS STORAGE FILE C IS DESIGNATED BY THE ANALYST. C THIS IS USEFUL WHEN A RUN MUST BE C INTERRUPTED (E.G., LUNCH) (SEE THE SAVE COMMAND) C AND IT IS DESIRED C TO PICK UP THE RUN LATER AT THE POINT C OF INTERRUPTION (SEE THE RESTORE COMMAND). C NOTE--THE SAVE COMMAND (AND ITS COMPLEMENT, THE RESTORE COMMAND) C BOTH USE UNFORMATTED FORTRAN I/O STATEMENTS C (FOR SPEED AND EFFICIENCY). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86/1 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --JANUARY 1981. C UPDATED --JUNE 1981. C UPDATED --NOVEMBER 1981. C UPDATED --JANUARY 1982. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1985. C UPDATED --JUNE 1986. C UPDATED --NOVEMBER 1987. (DIMENSION FOR I1DATA--1100 TO 100) C UPDATED --DECEMBER 1987. (DIMENSION FOR V--10000 TO MAXOBW) C UPDATED --FEBRUARY 1989. SOFT-CODE ALL (ALAN) C UPDATED --OCTOBER 1991. SUN HAS LIMIT ON # OF WORDS C UPDATED FOR UNFORMATTED I/O (2,046) C UPDATED --APRIL 1992. INCLUDE DPCO3D.INC (ALAN) C UPDATED --APRIL 1992. PPEDHE TO APEDSZ (ALAN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*80 ICANS C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCODB.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOFO.INC' INCLUDE 'DPCOF2.INC' INCLUDE 'DPCOSO.INC' INCLUDE 'DPCOGR.INC' INCLUDE 'DPCONP.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOTR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODG.INC' INCLUDE 'DPCOCO.INC' C APRIL 1992. ADD FOLLOWING INCLUDE FILE. INCLUDE 'DPCO3D.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='DPSA' ISUBN2='VE ' C ISUBRO='-999' IFOUND='YES' IERROR='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSAVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR 53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IWIDTH 54 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,55)(IANSLC(I),I=1,IWIDTH) 55 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ISAVNU 61 FORMAT('ISAVNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)ISAVNA 62 FORMAT('ISAVNA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)ISAVST 63 FORMAT('ISAVST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)ISAVFO 64 FORMAT('ISAVFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)ISAVAC 65 FORMAT('ISAVAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)ISAVFO 66 FORMAT('ISAVFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)ISAVCS 67 FORMAT('ISAVCS = ',A12) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************** C ** STEP 11-- ** C ** COPY OVER VARIABLES ** C ************************** C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNIT=ISAVNU IFILE=ISAVNA ISTAT=ISAVST IFORM=ISAVFO IACCES=ISAVAC IPROT=ISAVPR ICURST=ISAVCS C ISUBN0='SAVE' IERRFI='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO1199 WRITE(ICOUT,1193)IOUNIT 1193 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1194)IFILE 1194 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 1A12,2X,A12,2X,A12,2X,A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1196)ISUBN0,IERRFI 1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 1199 CONTINUE C C ******************************************* C ** STEP 12-- ** C ** CHECK TO SEE IF SAVE FILE MAY EXIST ** C ******************************************* C ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 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 DPSAVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE DESIRED SAVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' CANNOT BE GIVEN BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' THE REQUIRED SYSTEM MASS STORAGE FILE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' WHICH STORES SUCH SAVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' IS NOT AVAILABLE AT THIS INSTALLATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)ISTAT,ISAVST 1217 FORMAT('ISTAT,ISAVST = ',A12,2X,A12) CALL DPWRST('XXX','BUG ') GOTO9000 1290 CONTINUE C C **************************** C ** STEP 13-- ** C ** EXTRACT THE FILE NAME ** C ** (THE THIRD WORD) ** C **************************** C ISTEPN='13' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1310I=1,80 IFILE(I:I)=' ' 1310 CONTINUE C DO1320I=1,80 ICANS(I:I)=IANSLC(I) 1320 CONTINUE C ISTART=1 ISTOP=IWIDTH IF(NUMARG.LE.1) 1CALL DPW280(ICANS,ISTART,ISTOP,ICOL3,IBUGS2,ISUBRO,IERROR) IF(NUMARG.GE.2) 1CALL DPW380(ICANS,ISTART,ISTOP,ICOL3,IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C J=0 IF(ICOL3.GT.IWIDTH)GOTO1339 DO1330I=ICOL3,IWIDTH J=J+1 IFILE(J:J)=ICANS(I:I) 1330 CONTINUE 1339 CONTINUE C CALL DPDB80(IFILE,JMAX,IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 NCFILE=JMAX C IF(NCFILE.GE.1)GOTO1349 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1341) 1341 FORMAT('***** ERROR IN DPSAVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1342) 1342 FORMAT(' A FILE NAME IS REQUIRED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1343) 1343 FORMAT(' IN THE SAVE COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1344) 1344 FORMAT(' (FOR EXAMPLE, SAVE MEMORY DPRUN.DAT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1345) 1345 FORMAT(' BUT NONE WAS GIVEN HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1346) 1346 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1347)(IANSLC(I),I=1,IWIDTH) 1347 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IF(IWIDTH.LE.0)WRITE(ICOUT,999) IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') GOTO9000 1349 CONTINUE C 1390 CONTINUE C C ********************* C ** STEP 31-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='31' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 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 ** WRITE OUT TO THE SAVE FILE; C **************************************************************** C ISTEPN='41' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C -----BEGIN WRITING OUT----------------------- C C -----WRITE OUT COMMON FOR STANDARD I/O----- C WRITE(IOUNIT)IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW WRITE(IOUNIT)IFEEDB,IPRINT C C -----WRITE OUT COMMON FOR MACHINE CONSTANTS----- C WRITE(IOUNIT)(I1MACH(I),I=1,16) WRITE(IOUNIT)(R1MACH(I),I=1,5) WRITE(IOUNIT)(D1MACH(I),I=1,5) C C -----WRITE OUT COMMON FOR BUGS----- C WRITE(IOUNIT)(I1BUG(I),I=1,10) WRITE(IOUNIT)(IH1BUG(I),I=1,100) C C -----WRITE OUT COMMON FOR HOUSEKEEPING----- C C WRITE(IOUNIT)(I1HOUS(I),I=1,1050) WRITE(IOUNIT)(I1HOUS(I),I=1,5*MAXSTR+50) C WRITE(IOUNIT)(IH1HOU(I),I=1,2320) WRITE(IOUNIT)(IH1HOU(I),I=1,11*MAXSTR+120) C WRITE(IOUNIT)(R1HOUS(I),I=1,400) WRITE(IOUNIT)(R1HOUS(I),I=1,2*MAXSTR) C C -----WRITE OUT COMMON FOR DATA----- C C OCTOBER 1991. FOLLOWING BLOCK OF CODE HEAVILY MODIFIED TO HANDLE C PROBLEM ON SUN. SUN APPEARS TO LIMIT UNFORMATTED I/O TO 2,046 WORDS. C NEED TO BREAK INTO CHUNKS FOR MANY OF THESE WRITE OPERATIONS. C MAXWRD=100000 IF(IHOST1.EQ.'SUN')MAXWRD=2046 NLOOP1=(MAXOBV/MAXWRD)+1 NLOOP2=(MAXPOP/MAXWRD)+1 NLOOP3=(MAXOBW/MAXWRD)+1 C CCCC WRITE(IOUNIT)(I1DATA(I),I=1,1100) CCCCC WRITE(IOUNIT)(I1DATA(I),I=1,MAXOBS+100) WRITE(IOUNIT)(I1DATA(I),I=1,100) CCCCC WRITE(IOUNIT)(ISUB(I),I=1,MAXOBV) DO9112IK=1,NLOOP1 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXOBV)GOTO9117 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXOBV)JSTOP=MAXOBV WRITE(IOUNIT)(ISUB(I),I=JSTART,JSTOP) 9112 CONTINUE 9117 CONTINUE CCCCC WRITE(IOUNIT)(IH1DAT(I),I=1,3500) CCCCC WRITE(IOUNIT)(IH1DAT(I),I=1,3*MAXF1+3*MAXFN2+MAXF3) WRITE(IOUNIT)(IPARNC(I),I=1,MAXFN2) WRITE(IOUNIT)(IPANC2(I),I=1,MAXFN2) WRITE(IOUNIT)(IPAROP(I),I=1,MAXFN2) WRITE(IOUNIT)(MODEL(I),I=1,MAXF3) WRITE(IOUNIT)(IFUNC(I),I=1,MAXF1) WRITE(IOUNIT)(IFUNC2(I),I=1,MAXF1) WRITE(IOUNIT)(IFUNC3(I),I=1,MAXF1) CCCCC WRITE(IOUNIT)(R1DATA(I),I=1,10200) CCCCC WRITE(IOUNIT)(R1DATA(I),I=1,42200) WRITE(IOUNIT)(PARLIM(I),I=1,100) CCCCC WRITE(IOUNIT)(PRED(I),I=1,MAXOBV) DO9122IK=1,NLOOP1 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXOBV)GOTO9127 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXOBV)JSTOP=MAXOBV WRITE(IOUNIT)(PRED(I),I=JSTART,JSTOP) 9122 CONTINUE 9127 CONTINUE CCCCC WRITE(IOUNIT)(RES(I),I=1,MAXOBV) DO9132IK=1,NLOOP1 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXOBV)GOTO9137 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXOBV)JSTOP=MAXOBV WRITE(IOUNIT)(RES(I),I=JSTART,JSTOP) 9132 CONTINUE 9137 CONTINUE CCCCC WRITE(IOUNIT)(Y(I),I=1,MAXPOP) DO9142IK=1,NLOOP2 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXPOP)GOTO9147 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP WRITE(IOUNIT)(Y(I),I=JSTART,JSTOP) 9142 CONTINUE 9147 CONTINUE CCCCC WRITE(IOUNIT)(X(I),I=1,MAXPOP) DO9152IK=1,NLOOP2 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXPOP)GOTO9157 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP WRITE(IOUNIT)(X(I),I=JSTART,JSTOP) 9152 CONTINUE 9157 CONTINUE CCCCC WRITE(IOUNIT)(X3D(I),I=1,MAXPOP) DO9162IK=1,NLOOP2 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXPOP)GOTO9167 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP WRITE(IOUNIT)(X3D(I),I=JSTART,JSTOP) 9162 CONTINUE 9167 CONTINUE CCCCC WRITE(IOUNIT)(D(I),I=1,MAXPOP) DO9172IK=1,NLOOP2 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXPOP)GOTO9177 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP WRITE(IOUNIT)(D(I),I=JSTART,JSTOP) 9172 CONTINUE 9177 CONTINUE CCCCC WRITE(IOUNIT)(YPLOT(I),I=1,MAXPOP) DO9182IK=1,NLOOP2 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXPOP)GOTO9187 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP WRITE(IOUNIT)(YPLOT(I),I=JSTART,JSTOP) 9182 CONTINUE 9187 CONTINUE CCCCC WRITE(IOUNIT)(XPLOT(I),I=1,MAXPOP) DO9192IK=1,NLOOP2 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXPOP)GOTO9197 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP WRITE(IOUNIT)(XPLOT(I),I=JSTART,JSTOP) 9192 CONTINUE 9197 CONTINUE CCCCC WRITE(IOUNIT)(X2PLOT(I),I=1,MAXPOP) DO9212IK=1,NLOOP2 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXPOP)GOTO9217 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP WRITE(IOUNIT)(X2PLOT(I),I=JSTART,JSTOP) 9212 CONTINUE 9217 CONTINUE CCCCC WRITE(IOUNIT)(TAGPLO(I),I=1,MAXPOP) DO9222IK=1,NLOOP2 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXPOP)GOTO9227 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP WRITE(IOUNIT)(TAGPLO(I),I=JSTART,JSTOP) 9222 CONTINUE 9227 CONTINUE CCCCC WRITE(IOUNIT)(V(I),I=1,MAXOBW) DO9232IK=1,NLOOP3 JSTART=(IK-1)*MAXWRD+1 IF(JSTART.GT.MAXOBW)GOTO9237 JSTOP=IK*MAXWRD IF(JSTOP.GT.MAXOBW)JSTOP=MAXOBW WRITE(IOUNIT)(V(I),I=JSTART,JSTOP) 9232 CONTINUE 9237 CONTINUE CCCCC WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=1,100) ITEMP=100*100 IF(ITEMP.LE.MAXWRD)THEN WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=1,100) ELSE WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=1,10) WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=11,20) WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=21,30) WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=31,40) WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=41,50) WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=51,60) WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=61,70) WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=71,80) WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=81,90) WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=91,100) END IF CCCCC WRITE(IOUNIT)(R1DATA(I),I=1,2*MAXOBS+8*MAXPLP+200) CCCCC WRITE(IOUNIT)(V(I),I=1,10000) CCCCC WRITE(IOUNIT)(V(I),I=1,MAXWS) C C -----WRITE OUT COMMON FOR SUPPORT----- C WRITE(IOUNIT)(I1SUPP(I),I=1,50) WRITE(IOUNIT)(IH1SUP(I),I=1,70) WRITE(IOUNIT)(R1SUPP(I),I=1,60) C C -----WRITE OUT COMMON FOR SUBFILE I/O (UNIVAC ONLY)----- C WRITE(IOUNIT)(IBUF(I),I=1,504) C C -----WRITE OUT COMMON FOR DIAGRAMMATIC GRAPHICS----- C WRITE(IOUNIT)(IH1DIA(I),I=1,40) WRITE(IOUNIT)(R1DIAG(I),I=1,40) C C -----WRITE OUT COMMON FOR COLOR----- C WRITE(IOUNIT)ICOLOR WRITE(IOUNIT)IPLOTF C C -----WRITE OUT COMMON FOR BUGS AND ERROR----- C WRITE(IOUNIT)IBUGG4 WRITE(IOUNIT)ISUBG4 WRITE(IOUNIT)IERRG4 C C -----WRITE OUT COMMON FOR HOST----- C WRITE(IOUNIT)IHOST1 WRITE(IOUNIT)IHOST2 WRITE(IOUNIT)IHMOD1 WRITE(IOUNIT)IHMOD2 WRITE(IOUNIT)IOPSY1 WRITE(IOUNIT)IOPSY2 WRITE(IOUNIT)ICOMPI WRITE(IOUNIT)ISITE C C -----WRITE OUT COMMON FOR TRANSLATOR----- C WRITE(IOUNIT)ITRANS WRITE(IOUNIT)NCTRA1 WRITE(IOUNIT)NCTRA2 WRITE(IOUNIT)NUMTRA WRITE(IOUNIT)ICTRA1 WRITE(IOUNIT)ICTRA2 C C -----WRITE OUT COMMON FOR NON-PRINTING CHARACTERS----- C WRITE(IOUNIT)INULC WRITE(IOUNIT)ISOHC WRITE(IOUNIT)ISTXC WRITE(IOUNIT)IETXC WRITE(IOUNIT)IEOTC WRITE(IOUNIT)IENQC WRITE(IOUNIT)IACKC WRITE(IOUNIT)IBELC WRITE(IOUNIT)IBSC WRITE(IOUNIT)IHTC WRITE(IOUNIT)ILFC WRITE(IOUNIT)IVTC WRITE(IOUNIT)IFFC WRITE(IOUNIT)ICRC WRITE(IOUNIT)ISOC WRITE(IOUNIT)ISIC WRITE(IOUNIT)IDLEC WRITE(IOUNIT)IDC1C WRITE(IOUNIT)IDC2C WRITE(IOUNIT)IDC3C WRITE(IOUNIT)IDC4C WRITE(IOUNIT)INAKC WRITE(IOUNIT)ISYNC WRITE(IOUNIT)IETBC WRITE(IOUNIT)ICANC WRITE(IOUNIT)IEMC WRITE(IOUNIT)ISUBC WRITE(IOUNIT)IESCC WRITE(IOUNIT)IFSC WRITE(IOUNIT)IGSC WRITE(IOUNIT)IRSC WRITE(IOUNIT)IUSC C C -----WRITE OUT COMMON FOR GRAPHICS----- C WRITE(IOUNIT)IMANUF WRITE(IOUNIT)IMODEL WRITE(IOUNIT)IMODE2 WRITE(IOUNIT)IMODE3 WRITE(IOUNIT)IGCODE WRITE(IOUNIT)IGUNIT WRITE(IOUNIT)IGCONT WRITE(IOUNIT)NUMHPP WRITE(IOUNIT)NUMVPP WRITE(IOUNIT)ANUMHP WRITE(IOUNIT)ANUMVP WRITE(IOUNIT)IGCOLO WRITE(IOUNIT)IGBAUD WRITE(IOUNIT)AGERDE WRITE(IOUNIT)AGCODE WRITE(IOUNIT)ISOFT WRITE(IOUNIT)ISOFT2 WRITE(IOUNIT)ISOFT3 C C -----WRITE OUT COMMON FOR FILE OPERATIONS----- C WRITE(IOUNIT)(I1FILO(I),I=1,10) WRITE(IOUNIT)(IH1FIL(I),I=1,200) C C -----WRITE OUT COMMON FOR FILE OPERATIONS, PART 2----- C WRITE(IOUNIT)IMESNU WRITE(IOUNIT)IMESNA WRITE(IOUNIT)IMESST WRITE(IOUNIT)IMESFO WRITE(IOUNIT)IMESAC WRITE(IOUNIT)IMESPR WRITE(IOUNIT)IMESCS C WRITE(IOUNIT)INEWNU WRITE(IOUNIT)INEWNA WRITE(IOUNIT)INEWST WRITE(IOUNIT)INEWFO WRITE(IOUNIT)INEWAC WRITE(IOUNIT)INEWPR WRITE(IOUNIT)INEWCS C WRITE(IOUNIT)IMAINU WRITE(IOUNIT)IMAINA WRITE(IOUNIT)IMAIST WRITE(IOUNIT)IMAIFO WRITE(IOUNIT)IMAIAC WRITE(IOUNIT)IMAIPR WRITE(IOUNIT)IMAICS C WRITE(IOUNIT)IHELNU WRITE(IOUNIT)IHELNA WRITE(IOUNIT)IHELST WRITE(IOUNIT)IHELFO WRITE(IOUNIT)IHELAC WRITE(IOUNIT)IHELPR WRITE(IOUNIT)IHELCS C WRITE(IOUNIT)IBUGNU WRITE(IOUNIT)IBUGNA WRITE(IOUNIT)IBUGST WRITE(IOUNIT)IBUGFO WRITE(IOUNIT)IBUGAC WRITE(IOUNIT)IBUGPR WRITE(IOUNIT)IBUGCS C WRITE(IOUNIT)IQUENU WRITE(IOUNIT)IQUENA WRITE(IOUNIT)IQUEST WRITE(IOUNIT)IQUEFO WRITE(IOUNIT)IQUEAC WRITE(IOUNIT)IQUEPR WRITE(IOUNIT)IQUECS C WRITE(IOUNIT)ILOGNU WRITE(IOUNIT)ILOGNA WRITE(IOUNIT)ILOGST WRITE(IOUNIT)ILOGFO WRITE(IOUNIT)ILOGAC WRITE(IOUNIT)ILOGPR WRITE(IOUNIT)ILOGCS C WRITE(IOUNIT)IREANU WRITE(IOUNIT)IREANA WRITE(IOUNIT)IREAST WRITE(IOUNIT)IREAFO WRITE(IOUNIT)IREAAC WRITE(IOUNIT)IREAPR WRITE(IOUNIT)IREACS C WRITE(IOUNIT)IWRINU WRITE(IOUNIT)IWRINA WRITE(IOUNIT)IWRIST WRITE(IOUNIT)IWRIFO WRITE(IOUNIT)IWRIAC WRITE(IOUNIT)IWRIPR WRITE(IOUNIT)IWRICS C WRITE(IOUNIT)ISAVNU WRITE(IOUNIT)ISAVNA WRITE(IOUNIT)ISAVST WRITE(IOUNIT)ISAVFO WRITE(IOUNIT)ISAVAC WRITE(IOUNIT)ISAVPR WRITE(IOUNIT)ISAVCS C WRITE(IOUNIT)ILISNU WRITE(IOUNIT)ILISNA WRITE(IOUNIT)ILISST WRITE(IOUNIT)ILISFO WRITE(IOUNIT)ILISAC WRITE(IOUNIT)ILISPR WRITE(IOUNIT)ILISCS C WRITE(IOUNIT)ICRENU WRITE(IOUNIT)ICRENA WRITE(IOUNIT)ICREST WRITE(IOUNIT)ICREFO WRITE(IOUNIT)ICREAC WRITE(IOUNIT)ICREPR WRITE(IOUNIT)ICRECS C WRITE(IOUNIT)ISCRNU WRITE(IOUNIT)ISCRNA WRITE(IOUNIT)ISCRST WRITE(IOUNIT)ISCRFO WRITE(IOUNIT)ISCRAC WRITE(IOUNIT)ISCRPR WRITE(IOUNIT)ISCRCS C WRITE(IOUNIT)IDATNU WRITE(IOUNIT)IDATNA WRITE(IOUNIT)IDATST WRITE(IOUNIT)IDATFO WRITE(IOUNIT)IDATAC WRITE(IOUNIT)IDATPR WRITE(IOUNIT)IDATCS C WRITE(IOUNIT)IPL1NU WRITE(IOUNIT)IPL1NA WRITE(IOUNIT)IPL1ST WRITE(IOUNIT)IPL1FO WRITE(IOUNIT)IPL1AC WRITE(IOUNIT)IPL1PR WRITE(IOUNIT)IPL1CS C WRITE(IOUNIT)IPL2NU WRITE(IOUNIT)IPL2NA WRITE(IOUNIT)IPL2ST WRITE(IOUNIT)IPL2FO WRITE(IOUNIT)IPL2AC WRITE(IOUNIT)IPL2PR WRITE(IOUNIT)IPL2CS C WRITE(IOUNIT)IPRONU WRITE(IOUNIT)IPRONA WRITE(IOUNIT)IPROST WRITE(IOUNIT)IPROFO WRITE(IOUNIT)IPROAC WRITE(IOUNIT)IPROPR WRITE(IOUNIT)IPROCS C WRITE(IOUNIT)ICONNU WRITE(IOUNIT)ICONNA WRITE(IOUNIT)ICONST WRITE(IOUNIT)ICONFO WRITE(IOUNIT)ICONAC WRITE(IOUNIT)ICONPR WRITE(IOUNIT)ICONCS C WRITE(IOUNIT)ISACNU WRITE(IOUNIT)ISACNA WRITE(IOUNIT)ISACST WRITE(IOUNIT)ISACFO WRITE(IOUNIT)ISACAC WRITE(IOUNIT)ISACPR WRITE(IOUNIT)ISACCS C WRITE(IOUNIT)IEX1NU WRITE(IOUNIT)IEX1NA WRITE(IOUNIT)IEX1ST WRITE(IOUNIT)IEX1FO WRITE(IOUNIT)IEX1AC WRITE(IOUNIT)IEX1PR WRITE(IOUNIT)IEX1CS C WRITE(IOUNIT)IEX2NU WRITE(IOUNIT)IEX2NA WRITE(IOUNIT)IEX2ST WRITE(IOUNIT)IEX2FO WRITE(IOUNIT)IEX2AC WRITE(IOUNIT)IEX2PR WRITE(IOUNIT)IEX2CS C WRITE(IOUNIT)IEX3NU WRITE(IOUNIT)IEX3NA WRITE(IOUNIT)IEX3ST WRITE(IOUNIT)IEX3FO WRITE(IOUNIT)IEX3AC WRITE(IOUNIT)IEX3PR WRITE(IOUNIT)IEX3CS C WRITE(IOUNIT)IEX4NU WRITE(IOUNIT)IEX4NA WRITE(IOUNIT)IEX4ST WRITE(IOUNIT)IEX4FO WRITE(IOUNIT)IEX4AC WRITE(IOUNIT)IEX4PR WRITE(IOUNIT)IEX4CS C WRITE(IOUNIT)IEX5NU WRITE(IOUNIT)IEX5NA WRITE(IOUNIT)IEX5ST WRITE(IOUNIT)IEX5FO WRITE(IOUNIT)IEX5AC WRITE(IOUNIT)IEX5PR WRITE(IOUNIT)IEX5CS C WRITE(IOUNIT)IFCHAR C C -----WRITE OUT COMMON FOR PLOT CONTROL----- C WRITE(IOUNIT)(IDMANU(I),I=1,MAXDV) WRITE(IOUNIT)(IDMODE(I),I=1,MAXDV) WRITE(IOUNIT)(IDMOD2(I),I=1,MAXDV) WRITE(IOUNIT)(IDMOD3(I),I=1,MAXDV) WRITE(IOUNIT)(IDPOWE(I),I=1,MAXDV) WRITE(IOUNIT)(IDCONT(I),I=1,MAXDV) WRITE(IOUNIT)(IDCOLO(I),I=1,MAXDV) WRITE(IOUNIT)(IDSCRE(I),I=1,MAXDV) WRITE(IOUNIT)(IDSCRO(I),I=1,MAXDV) WRITE(IOUNIT)(IDPAER(I),I=1,MAXDV) WRITE(IOUNIT)(IDSEGM(I),I=1,MAXDV) WRITE(IOUNIT)(IDSOFT(I),I=1,MAXDV) WRITE(IOUNIT)(IDSOF2(I),I=1,MAXDV) WRITE(IOUNIT)(IDSOF3(I),I=1,MAXDV) C WRITE(IOUNIT)(IDCODE(I),I=1,MAXDV) WRITE(IOUNIT)(IDUNIT(I),I=1,MAXDV) WRITE(IOUNIT)(IDNHPP(I),I=1,MAXDV) WRITE(IOUNIT)(IDNVPP(I),I=1,MAXDV) WRITE(IOUNIT)(IDBAUD(I),I=1,MAXDV) WRITE(IOUNIT)NUMDEV,MAXDEV C WRITE(IOUNIT)IERASW,IBELSW,ISORSW,ICOPSW WRITE(IOUNIT)IPENSW WRITE(IOUNIT)IBACCO,IMARCO WRITE(IOUNIT)IDEFXC,IDEFBK,IDEFMC,IDEPEC WRITE(IOUNIT)ISEQSW WRITE(IOUNIT)IFENSW WRITE(IOUNIT)INEGSW WRITE(IOUNIT)IVISSW,IPEDSW,IPEDCO WRITE(IOUNIT)IDEFMA,IDEFMO,IDEFM2,IDEFM3 WRITE(IOUNIT)IDEFPO,IDEFCN,IDEFDC C WRITE(IOUNIT)NUMRIN,NUMCOP WRITE(IOUNIT)NUMSEQ WRITE(IOUNIT)IDEFVP,IDEFHP,IDEFUN C WRITE(IOUNIT)BAWIDT,BARSPA,DEFBAS WRITE(IOUNIT)AORIXC,AORIYC,AORIZC WRITE(IOUNIT)AEYEXC,AEYEYC,AEYEZC CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 (ALAN) CCCCC WRITE(IOUNIT)PPEDHE WRITE(IOUNIT)APEDSZ WRITE(IOUNIT)DEFSZ,DEFTL C WRITE(IOUNIT)IGRASW C WRITE(IOUNIT)PGRAXO,PGRAYO,PGRAXC,PGRAYC,PGRAXN,PGRAYN WRITE(IOUNIT)PMARXC WRITE(IOUNIT)PGRAXF,PGRAYF WRITE(IOUNIT)PCROXC,PCROYC C WRITE(IOUNIT)IDIASW C WRITE(IOUNIT)PDIAXC,PDIAYC,PDIAX2,PDIAY2 WRITE(IOUNIT)PDIAHE,PDIAWI,PDIAVG,PDIAHG C WRITE(IOUNIT)PWXMIN,PWXMAX,PWYMIN,PWYMAX WRITE(IOUNIT)WWXMIN,WWXMAX,WWYMIN,WWYMAX C WRITE(IOUNIT)IX1MIN,IX1MAX,IY1MIN,IY1MAX WRITE(IOUNIT)IX2MIN,IX2MAX,IY2MIN,IY2MAX C WRITE(IOUNIT)PXMIN,PXMAX,PYMIN,PYMAX WRITE(IOUNIT)PDXMIN,PDXMAX,PDYMIN,PDYMAX WRITE(IOUNIT)PGXMIN,PGXMAX,PGYMIN,PGYMAX WRITE(IOUNIT)GX1MIN,GX1MAX,GY1MIN,GY1MAX WRITE(IOUNIT)GX2MIN,GX2MAX,GY2MIN,GY2MAX WRITE(IOUNIT)DX1MIN,DX1MAX,DY1MIN,DY1MAX WRITE(IOUNIT)DX2MIN,DX2MAX,DY2MIN,DY2MAX WRITE(IOUNIT)FX1MIN,FX1MAX,FY1MIN,FY1MAX WRITE(IOUNIT)FX2MIN,FX2MAX,FY2MIN,FY2MAX C WRITE(IOUNIT)IX1FSW,IX2FSW,IY1FSW,IY2FSW WRITE(IOUNIT)IX1FPA,IX2FPA,IY1FPA,IY2FPA WRITE(IOUNIT)IX1FCO,IX2FCO,IY1FCO,IY2FCO C WRITE(IOUNIT)PFRATH C WRITE(IOUNIT)IX1TSW,IX2TSW,IY1TSW,IY2TSW WRITE(IOUNIT)IX1JSW,IX2JSW,IY1JSW,IY2JSW WRITE(IOUNIT)IX1NSW,IX2NSW,IY1NSW,IY2NSW WRITE(IOUNIT)IX1TSC,IX2TSC,IY1TSC,IY2TSC WRITE(IOUNIT)IX1TJU,IX2TJU,IY1TJU,IY2TJU WRITE(IOUNIT)IX1TCO,IX2TCO,IY1TCO,IY2TCO C WRITE(IOUNIT)NMJX1T,NMJX2T,NMJY1T,NMJY2T WRITE(IOUNIT)NMNX1T,NMNX2T,NMNY1T,NMNY2T WRITE(IOUNIT)NX1COO,NX2COO,NY1COO,NY2COO WRITE(IOUNIT)NX1CMN,NX2CMN,NY1CMN,NY2CMN WRITE(IOUNIT)MAXTIC C WRITE(IOUNIT)(PX1COO(I),I=1,MAXTC) WRITE(IOUNIT)(PX2COO(I),I=1,MAXTC) WRITE(IOUNIT)(PY1COO(I),I=1,MAXTC) WRITE(IOUNIT)(PY2COO(I),I=1,MAXTC) WRITE(IOUNIT)(X1COOR(I),I=1,MAXTC) WRITE(IOUNIT)(X2COOR(I),I=1,MAXTC) WRITE(IOUNIT)(Y1COOR(I),I=1,MAXTC) WRITE(IOUNIT)(Y2COOR(I),I=1,MAXTC) WRITE(IOUNIT)(PX1CMN(I),I=1,MAXTC) WRITE(IOUNIT)(PX2CMN(I),I=1,MAXTC) WRITE(IOUNIT)(PY1CMN(I),I=1,MAXTC) WRITE(IOUNIT)(PY2CMN(I),I=1,MAXTC) WRITE(IOUNIT)(X1COMN(I),I=1,MAXTC) WRITE(IOUNIT)(X2COMN(I),I=1,MAXTC) WRITE(IOUNIT)(Y1COMN(I),I=1,MAXTC) WRITE(IOUNIT)(Y2COMN(I),I=1,MAXTC) WRITE(IOUNIT)PX1TLE,PX2TLE,PY1TLE,PY2TLE WRITE(IOUNIT)PTICTH,PMNTFA C WRITE(IOUNIT)IX1ZSW,IX2ZSW,IY1ZSW,IY2ZSW WRITE(IOUNIT)IX1ZFO,IX2ZFO,IY1ZFO,IY2ZFO WRITE(IOUNIT)IX1ZCA,IX2ZCA,IY1ZCA,IY2ZCA WRITE(IOUNIT)IX1ZJU,IX2ZJU,IY1ZJU,IY2ZJU WRITE(IOUNIT)IX1ZDI,IX2ZDI,IY1ZDI,IY2ZDI WRITE(IOUNIT)IX1ZFI,IX2ZFI,IY1ZFI,IY2ZFI WRITE(IOUNIT)IX1ZCO,IX2ZCO,IY1ZCO,IY2ZCO C WRITE(IOUNIT)IX1ZDP,IX2ZDP,IY1ZDP,IY2ZDP C WRITE(IOUNIT)PX1ZDS,PX2ZDS,PY1ZDS,PY2ZDS WRITE(IOUNIT)AX1ZAN,AX2ZAN,AY1ZAN,AY2ZAN WRITE(IOUNIT)PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG WRITE(IOUNIT)PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG WRITE(IOUNIT)PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG WRITE(IOUNIT)PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG WRITE(IOUNIT)PTIZTH C WRITE(IOUNIT)IVGRSW,IHGRSW WRITE(IOUNIT)IVGRPA,IHGRPA WRITE(IOUNIT)IVGRCO,IHGRCO C WRITE(IOUNIT)PVGRTH,PHGRTH C WRITE(IOUNIT)(ITITTE(I),I=1,MAXCH) WRITE(IOUNIT)ITITFO,ITITCA,ITITFI,ITITCO C WRITE(IOUNIT)NCTITL C WRITE(IOUNIT)PTITHE,PTITWI,PTITVG,PTITHG,PTITTH,PTITDS C WRITE(IOUNIT)(IX1LTE(I),I=1,MAXCH) WRITE(IOUNIT)IX1LFO,IX1LCA,IX1LFI,IX1LCO WRITE(IOUNIT)(IX2LTE(I),I=1,MAXCH) WRITE(IOUNIT)IX2LFO,IX2LCA,IX2LFI,IX2LCO WRITE(IOUNIT)(IX3LTE(I),I=1,MAXCH) WRITE(IOUNIT)IX3LFO,IX3LCA,IX3LFI,IX3LCO WRITE(IOUNIT)(IY1LTE(I),I=1,MAXCH) WRITE(IOUNIT)IY1LFO,IY1LCA,IY1LFI,IY1LCO WRITE(IOUNIT)(IY2LTE(I),I=1,MAXCH) WRITE(IOUNIT)IY2LFO,IY2LCA,IY2LFI,IY2LCO C WRITE(IOUNIT)NCX1LA,NCX2LA,NCX3LA,NCY1LA,NCY2LA C WRITE(IOUNIT)PX1LHE,PX1LWI,PX1LVG,PX1LHG,PX1LTH,PX1LDS WRITE(IOUNIT)PX2LHE,PX2LWI,PX2LVG,PX2LHG,PX2LTH,PX2LDS WRITE(IOUNIT)PX3LHE,PX3LWI,PX3LVG,PX3LHG,PX3LTH,PX3LDS WRITE(IOUNIT)PY1LHE,PY1LWI,PY1LVG,PY1LHG,PY1LTH,PY1LDS WRITE(IOUNIT)PY2LHE,PY2LWI,PY2LVG,PY2LHG,PY2LTH,PY2LDS C WRITE(IOUNIT)(ILEGTE(I),I=1,MAXLG2) WRITE(IOUNIT)(ILEGFO(I),I=1,MAXLG) WRITE(IOUNIT)(ILEGCA(I),I=1,MAXLG) WRITE(IOUNIT)(ILEGJU(I),I=1,MAXLG) WRITE(IOUNIT)(ILEGDI(I),I=1,MAXLG) WRITE(IOUNIT)(ILEGFI(I),I=1,MAXLG) WRITE(IOUNIT)(ILEGCO(I),I=1,MAXLG) WRITE(IOUNIT)(ILEGNA(I),I=1,MAXLG) C WRITE(IOUNIT)(ILEGST(I),I=1,MAXLG) WRITE(IOUNIT)(ILEGSP(I),I=1,MAXLG) WRITE(IOUNIT)NCLEG,MXCLEG WRITE(IOUNIT)NUMLEG,MAXLEG C WRITE(IOUNIT)(PLEGXC(I),I=1,MAXLG) WRITE(IOUNIT)(PLEGYC(I),I=1,MAXLG) WRITE(IOUNIT)(PLEGHE(I),I=1,MAXLG) WRITE(IOUNIT)(PLEGWI(I),I=1,MAXLG) WRITE(IOUNIT)(PLEGVG(I),I=1,MAXLG) WRITE(IOUNIT)(PLEGHG(I),I=1,MAXLG) WRITE(IOUNIT)(PLEGTH(I),I=1,MAXLG) WRITE(IOUNIT)(ALEGAN(I),I=1,MAXLG) C WRITE(IOUNIT)(IBOBFI(I),I=1,MAXBX) WRITE(IOUNIT)(IBOBCO(I),I=1,MAXBX) WRITE(IOUNIT)(IBOPPA(I),I=1,MAXBX) WRITE(IOUNIT)(IBOPCO(I),I=1,MAXBX) WRITE(IOUNIT)(IBOFPA(I),I=1,MAXBX) WRITE(IOUNIT)(IBOFCO(I),I=1,MAXBX) C WRITE(IOUNIT)NUMBOX,MAXBOX C WRITE(IOUNIT)((PBOXXC(I,J),I=1,MAXBX),J=1,2) WRITE(IOUNIT)((PBOXYC(I,J),I=1,MAXBX),J=1,2) WRITE(IOUNIT)(PBOPTH(I),I=1,MAXBX) WRITE(IOUNIT)(PBOPGA(I),I=1,MAXBX) WRITE(IOUNIT)(PBOFTH(I),I=1,MAXBX) C WRITE(IOUNIT)(IARRPA(I),I=1,MAXAR) WRITE(IOUNIT)(IARRCO(I),I=1,MAXAR) WRITE(IOUNIT)(IARHFI(I),I=1,MAXAR) C WRITE(IOUNIT)NUMARR,MAXARR C WRITE(IOUNIT)((PARRXC(I,J),I=1,MAXAR),J=1,2) WRITE(IOUNIT)((PARRYC(I,J),I=1,MAXAR),J=1,2) WRITE(IOUNIT)(PARRTH(I),I=1,MAXAR) WRITE(IOUNIT)(PARHLE(I),I=1,MAXAR) WRITE(IOUNIT)(PARHWI(I),I=1,MAXAR) C WRITE(IOUNIT)(ISEGPA(I),I=1,MAXSG) WRITE(IOUNIT)(ISEGCO(I),I=1,MAXSG) C WRITE(IOUNIT)NUMSEG,MAXSEG C WRITE(IOUNIT)((PSEGXC(I,J),I=1,MAXSG),J=1,2) WRITE(IOUNIT)((PSEGYC(I,J),I=1,MAXSG),J=1,2) WRITE(IOUNIT)(PSEGTH(I),I=1,MAXSG) C WRITE(IOUNIT)(ILINPA(I),I=1,MAXLN) WRITE(IOUNIT)(ILINCO(I),I=1,MAXLN) C WRITE(IOUNIT)MAXLIN C WRITE(IOUNIT)(PLINTH(I),I=1,MAXLN) WRITE(IOUNIT)(PLINLE(I),I=1,MAXLN) WRITE(IOUNIT)(PLINL2(I),I=1,MAXLN) WRITE(IOUNIT)(PLINL3(I),I=1,MAXLN) WRITE(IOUNIT)(PLINGA(I),I=1,MAXLN) WRITE(IOUNIT)(PLING2(I),I=1,MAXLN) WRITE(IOUNIT)(PLING3(I),I=1,MAXLN) C WRITE(IOUNIT)(ICHAPA(I),I=1,MAXCH2) WRITE(IOUNIT)(ICHAFO(I),I=1,MAXCH2) WRITE(IOUNIT)(ICHACA(I),I=1,MAXCH2) WRITE(IOUNIT)(ICHAJU(I),I=1,MAXCH2) WRITE(IOUNIT)(ICHADI(I),I=1,MAXCH2) WRITE(IOUNIT)(ICHAFI(I),I=1,MAXCH2) WRITE(IOUNIT)(ICHACO(I),I=1,MAXCH2) C WRITE(IOUNIT)MAXCHA C WRITE(IOUNIT)(PCHAHE(I),I=1,MAXCH2) WRITE(IOUNIT)(PCHAWI(I),I=1,MAXCH2) WRITE(IOUNIT)(PCHAVG(I),I=1,MAXCH2) WRITE(IOUNIT)(PCHAHG(I),I=1,MAXCH2) WRITE(IOUNIT)(PCHATH(I),I=1,MAXCH2) WRITE(IOUNIT)(ACHAAN(I),I=1,MAXCH2) C WRITE(IOUNIT)(ITEXTE(I),I=1,MAXCH) WRITE(IOUNIT)ITEXPA,ITEXFO,ITEXCA,ITEXJU,ITEXDI,ITEXAU,ITEXFI, 1ITEXCO WRITE(IOUNIT)IDEFPA,IDEFFO,IDEFCA,IDEFJU,IDEFDI,IDEFAU,IDEFFI, 1IDEFCO WRITE(IOUNIT)ITEXCR,ITEXLF WRITE(IOUNIT)IDEFCR,IDEFLF WRITE(IOUNIT)ITEXSY,ITEXSP WRITE(IOUNIT)IDEFSY,IDEFSP C WRITE(IOUNIT)NCTEXT,MXCTEX C WRITE(IOUNIT)PTEXHE,PTEXWI,PTEXVG,PTEXHG WRITE(IOUNIT)PTEXTH,PTEXLE,ATEXAN WRITE(IOUNIT)PDEFHE,PDEFWI,PDEFVG,PDEFHG WRITE(IOUNIT)PDEFTH,PDEFLE,ADEFAN WRITE(IOUNIT)PTEXMR WRITE(IOUNIT)PDEFMR WRITE(IOUNIT)PXSTAR,PYSTAR WRITE(IOUNIT)PXEND,PYEND C WRITE(IOUNIT)(IFILSW(I),I=1,MAXFL) WRITE(IOUNIT)(IFILPA(I),I=1,MAXFL) WRITE(IOUNIT)(IFILCO(I),I=1,MAXFL) WRITE(IOUNIT)IDEFFS WRITE(IOUNIT)IDEFFP WRITE(IOUNIT)IDEFFC C WRITE(IOUNIT)MAXFIL C WRITE(IOUNIT)(PFILSP(I),I=1,MAXFL) WRITE(IOUNIT)(PFILTH(I),I=1,MAXFL) WRITE(IOUNIT)(AFILBA(I),I=1,MAXFL) WRITE(IOUNIT)PDEFFG WRITE(IOUNIT)PDEFFT WRITE(IOUNIT)ADEFFB C WRITE(IOUNIT)(IPATSW(I),I=1,MAXPT) WRITE(IOUNIT)(IPATPA(I),I=1,MAXPT) WRITE(IOUNIT)(IPATLI(I),I=1,MAXPT) WRITE(IOUNIT)(IPATCO(I),I=1,MAXPT) WRITE(IOUNIT)IDEFPS WRITE(IOUNIT)IDEFPP WRITE(IOUNIT)IDEFPL WRITE(IOUNIT)IDEFPC C WRITE(IOUNIT)MAXPAT C WRITE(IOUNIT)(PPATHE(I),I=1,MAXPT) WRITE(IOUNIT)(PPATWI(I),I=1,MAXPT) WRITE(IOUNIT)(PPATSP(I),I=1,MAXPT) WRITE(IOUNIT)(PPATTH(I),I=1,MAXPT) WRITE(IOUNIT)PDEFPH WRITE(IOUNIT)PDEFPW WRITE(IOUNIT)PDEFPG WRITE(IOUNIT)PDEFPT C WRITE(IOUNIT)(ISPISW(I),I=1,MAXSP) WRITE(IOUNIT)(ISPILI(I),I=1,MAXSP) WRITE(IOUNIT)(ISPICO(I),I=1,MAXSP) WRITE(IOUNIT)IDEFSS WRITE(IOUNIT)IDEFSL WRITE(IOUNIT)IDEFSC C WRITE(IOUNIT)MAXSPI C WRITE(IOUNIT)(PSPITH(I),I=1,MAXSP) WRITE(IOUNIT)(ASPIBA(I),I=1,MAXSP) WRITE(IOUNIT)PDEFST WRITE(IOUNIT)ADEFSB C WRITE(IOUNIT)(IBARSW(I),I=1,MAXBA) WRITE(IOUNIT)(IBABLI(I),I=1,MAXBA) WRITE(IOUNIT)(IBABCO(I),I=1,MAXBA) WRITE(IOUNIT)(IBAFSW(I),I=1,MAXBA) WRITE(IOUNIT)(IBAFCO(I),I=1,MAXBA) WRITE(IOUNIT)(IBAPTY(I),I=1,MAXBA) WRITE(IOUNIT)(IBAPLI(I),I=1,MAXBA) WRITE(IOUNIT)(IBAPCO(I),I=1,MAXBA) WRITE(IOUNIT)IDEBSW WRITE(IOUNIT)IDEBBL WRITE(IOUNIT)IDEBBC WRITE(IOUNIT)IDEBFS WRITE(IOUNIT)IDEBFC WRITE(IOUNIT)IDEBPT WRITE(IOUNIT)IDEBPL WRITE(IOUNIT)IDEBPC C WRITE(IOUNIT)MAXBAR C WRITE(IOUNIT)(ABARBA(I),I=1,MAXBA) WRITE(IOUNIT)(ABARWI(I),I=1,MAXBA) WRITE(IOUNIT)(PBABTH(I),I=1,MAXBA) WRITE(IOUNIT)(PBAPTH(I),I=1,MAXBA) WRITE(IOUNIT)(PBAPSP(I),I=1,MAXBA) WRITE(IOUNIT)ADEBBA WRITE(IOUNIT)ADEBWI WRITE(IOUNIT)PDEBBT WRITE(IOUNIT)PDEBPT WRITE(IOUNIT)PDEBPS C WRITE(IOUNIT)(IREGSW(I),I=1,MAXRG) WRITE(IOUNIT)(IREBLI(I),I=1,MAXRG) WRITE(IOUNIT)(IREBCO(I),I=1,MAXRG) WRITE(IOUNIT)(IREFSW(I),I=1,MAXRG) WRITE(IOUNIT)(IREFCO(I),I=1,MAXRG) WRITE(IOUNIT)(IREPTY(I),I=1,MAXRG) WRITE(IOUNIT)(IREPLI(I),I=1,MAXRG) WRITE(IOUNIT)(IREPCO(I),I=1,MAXRG) WRITE(IOUNIT)IDERSW WRITE(IOUNIT)IDERBL WRITE(IOUNIT)IDERBC WRITE(IOUNIT)IDERFS WRITE(IOUNIT)IDERFC WRITE(IOUNIT)IDERPT WRITE(IOUNIT)IDERPL WRITE(IOUNIT)IDERPC C WRITE(IOUNIT)MAXREG C WRITE(IOUNIT)(AREGBA(I),I=1,MAXRG) WRITE(IOUNIT)(AREGWI(I),I=1,MAXRG) WRITE(IOUNIT)(PREBTH(I),I=1,MAXRG) WRITE(IOUNIT)(PREPTH(I),I=1,MAXRG) WRITE(IOUNIT)(PREPSP(I),I=1,MAXRG) WRITE(IOUNIT)ADERBA WRITE(IOUNIT)ADERWI WRITE(IOUNIT)PDERBT WRITE(IOUNIT)PDERPT WRITE(IOUNIT)PDERPS C WRITE(IOUNIT)(IMARSW(I),I=1,MAXMR) WRITE(IOUNIT)(IMABLI(I),I=1,MAXMR) WRITE(IOUNIT)(IMABCO(I),I=1,MAXMR) WRITE(IOUNIT)(IMAFSW(I),I=1,MAXMR) WRITE(IOUNIT)(IMAFCO(I),I=1,MAXMR) WRITE(IOUNIT)(IMAPTY(I),I=1,MAXMR) WRITE(IOUNIT)(IMAPLI(I),I=1,MAXMR) WRITE(IOUNIT)(IMAPCO(I),I=1,MAXMR) WRITE(IOUNIT)IDEMSW WRITE(IOUNIT)IDEMBL WRITE(IOUNIT)IDEMBC WRITE(IOUNIT)IDEMFS WRITE(IOUNIT)IDEMFC WRITE(IOUNIT)IDEMPT WRITE(IOUNIT)IDEMPL WRITE(IOUNIT)IDEMPC C WRITE(IOUNIT)MAXMAR C WRITE(IOUNIT)(AMARBA(I),I=1,MAXMR) WRITE(IOUNIT)(AMARWI(I),I=1,MAXMR) WRITE(IOUNIT)(PMABTH(I),I=1,MAXMR) WRITE(IOUNIT)(PMAPTH(I),I=1,MAXMR) WRITE(IOUNIT)(PMAPSP(I),I=1,MAXMR) WRITE(IOUNIT)ADEMBA WRITE(IOUNIT)ADEMWI WRITE(IOUNIT)PDEMBT WRITE(IOUNIT)PDEMPT WRITE(IOUNIT)PDEMPS C WRITE(IOUNIT)(ITEXSW(I),I=1,MAXTX) WRITE(IOUNIT)(ITEBLI(I),I=1,MAXTX) WRITE(IOUNIT)(ITEBCO(I),I=1,MAXTX) WRITE(IOUNIT)(ITEFSW(I),I=1,MAXTX) WRITE(IOUNIT)(ITEFCO(I),I=1,MAXTX) WRITE(IOUNIT)(ITEPTY(I),I=1,MAXTX) WRITE(IOUNIT)(ITEPLI(I),I=1,MAXTX) WRITE(IOUNIT)(ITEPCO(I),I=1,MAXTX) WRITE(IOUNIT)IDETSW WRITE(IOUNIT)IDETBL WRITE(IOUNIT)IDETBC WRITE(IOUNIT)IDETFS WRITE(IOUNIT)IDETFC WRITE(IOUNIT)IDETPT WRITE(IOUNIT)IDETPL WRITE(IOUNIT)IDETPC C WRITE(IOUNIT)MAXTEX C WRITE(IOUNIT)(ATEXBA(I),I=1,MAXTX) WRITE(IOUNIT)(ATEXWI(I),I=1,MAXTX) WRITE(IOUNIT)(PTEBTH(I),I=1,MAXTX) WRITE(IOUNIT)(PTEPTH(I),I=1,MAXTX) WRITE(IOUNIT)(PTEPSP(I),I=1,MAXTX) WRITE(IOUNIT)ADETBA WRITE(IOUNIT)ADETWI WRITE(IOUNIT)PDETBT WRITE(IOUNIT)PDETPT WRITE(IOUNIT)PDETPS C C -----END WRITING OUT----------------------- C C *************************** C ** STEP 42-- ** C ** WRITE OUT A MESSAGE ** C *************************** C ISTEPN='42' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IERROR.EQ.'YES')GOTO4290 IF(IFEEDB.EQ.'OFF')GOTO4290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4211) 4211 FORMAT('THE SAVING OF ALL INTERNAL DATAPLOT VARIABLES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4212) 4212 FORMAT(' PARAMETERS, ETC. HAS JUST BEEN COMPLETED') CALL DPWRST('XXX','BUG ') 4290 CONTINUE C C *********************** C ** STEP 51-- ** C ** CLOSE THE FILE. ** C *********************** C ISTEPN='51' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IENDFI='ON' IREWIN='ON' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSAVE--') 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 ') 9090 CONTINUE C RETURN END SUBROUTINE DPSBLI(ICOM,IHARG,IARGT,ARG,NUMARG, 1ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1MAXSUB, 1IFOUND,IERROR) C C PURPOSE--DEFINE LIMITS FOR SUBREGIONS. C SUBREGION XLIMITS 10 20 C SUBREGION YLIMITS 10 20 C SUBREGION 1 YLIMITS 10 20 C SUBREGION 2 YLIMITS 10 20 C INPUT ARGUMENTS--ICOM (A HOLLERITH VARIABLE) C --IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG C OUTPUT ARGUMENTS-- C --ASUBXL = COORDINATE FOR LOWER X LIMIT C --ASUBXU = COORDINATE FOR UPPER X LIMIT C --ASUBYL = COORDINATE FOR LOWER Y LIMIT C --ASUBYU = COORDINATE FOR UPPER Y LIMIT C --MAXSUB = MAXIMUM NUMBER OF SUBREGIONS C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/11 C ORIGINAL VERSION--NOVEMBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C DIMENSION ASUBXL(*) DIMENSION ASUBXU(*) DIMENSION ASUBYL(*) DIMENSION ASUBYU(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(ICOM.NE.'SUBR')THEN IFOUND='NO' GOTO9000 ENDIF C IF(NUMARG.LE.0)THEN GOTO9000 ENDIF IF(IHARG(NUMARG).EQ.'?')GOTO8100 1090 CONTINUE C C ***************************************************** C ** CHECK IF THE FIRST ARGUMENT IS NUMERIC ** C ** (THIS SHOULD DEFINE WHICH SUBREGION IS BEING ** C ** SET) ** C ***************************************************** C IF(IARGT(1).EQ.'NUMB')THEN ISUBID=INT(ARG(1)+0.5) IF(ISUBID.LT.1 .OR. ISUBID.GT.MAXSUB)ISUBID=1 IWORD=2 ELSE IWORD=1 ISUBID=1 ENDIF C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** THE HORIZONTAL SUBREGION LIMITS ARE TO BE FIXED** C ***************************************************** C IF(IHARG(IWORD).EQ.'XLIM')GOTO1100 GOTO1199 C 1100 CONTINUE IF(NUMARG.LE.IWORD)GOTO1110 IF(IHARG(IWORD+1).EQ.'DEFA')GOTO1110 IF(IARGT(IWORD+1).EQ.'NUMB'.AND.IARGT(IWORD+2).EQ.'NUMB')GOTO1120 GOTO1110 C 1110 CONTINUE IFOUND='YES' ASUBXL(ISUBID)=CPUMIN ASUBXU(ISUBID)=CPUMAX 1113 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1115)ISUBID 1115 FORMAT('THE X LIMITS FOR SUB-REGION ',I8,' HAVE JUST BEEN SET') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117) 1117 FORMAT('TO THE FULL PLOT AREA.') CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO9000 C 1120 CONTINUE IFOUND='YES' ASUBXL(ISUBID)=ARG(IWORD+1) ASUBXU(ISUBID)=ARG(IWORD+2) IF(ASUBXL(ISUBID).GT.ASUBXU(ISUBID))THEN ATEMP=ASUBXL(ISUBID) ASUBXL(ISUBID)=ASUBXU(ISUBID) ASUBXU(ISUBID)=ATEMP ENDIF C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125)ISUBID 1125 FORMAT('THE SUBREGION X LIMITS FOR SUBREGION ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126)ASUBXL(ISUBID),ASUBXU(ISUBID) 1126 FORMAT('HAVE JUST BEEN SET TO ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO9000 C 1199 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** THE VERTICAL SUBREGION LIMITS ARE TO BE FIXED** C ***************************************************** C IF(IHARG(IWORD).EQ.'YLIM')GOTO2100 GOTO2199 C 2100 CONTINUE IF(NUMARG.LE.IWORD)GOTO2110 IF(IHARG(IWORD+1).EQ.'DEFA')GOTO2110 IF(IARGT(IWORD+1).EQ.'NUMB'.AND.IARGT(IWORD+2).EQ.'NUMB')GOTO2120 GOTO2110 C 2110 CONTINUE IFOUND='YES' ASUBYL(ISUBID)=CPUMIN ASUBYU(ISUBID)=CPUMAX 2113 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO2119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2115)ISUBID 2115 FORMAT('THE Y LIMITS FOR SUB-REGION ',I8,' HAVE JUST BEEN SET') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2117) 2117 FORMAT('TO THE FULL PLOT AREA.') CALL DPWRST('XXX','BUG ') 2119 CONTINUE GOTO9000 C 2120 CONTINUE IFOUND='YES' ASUBYL(ISUBID)=ARG(IWORD+1) ASUBYU(ISUBID)=ARG(IWORD+2) IF(ASUBYL(ISUBID).GT.ASUBYU(ISUBID))THEN ATEMP=ASUBYL(ISUBID) ASUBYL(ISUBID)=ASUBYU(ISUBID) ASUBYU(ISUBID)=ATEMP ENDIF C IF(IFEEDB.EQ.'OFF')GOTO2129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2125)ISUBID 2125 FORMAT('THE SUBREGION Y LIMITS FOR SUBREGION ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2126)ASUBYL(ISUBID),ASUBYU(ISUBID) 2126 FORMAT('HAVE JUST BEEN SET TO ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 2129 CONTINUE GOTO9000 C 2199 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN BOTH THE HORIZONTAL AND ** C ** VERTICAL SUBREGION LIMITS ARE TO BE FIXED ** C ***************************************************** C IF(IHARG(IWORD).EQ.'LIMI')GOTO3100 GOTO3199 C 3100 CONTINUE IF(NUMARG.LE.IWORD)GOTO3110 IF(IHARG(IWORD+1).EQ.'DEFA')GOTO3110 IF(IARGT(IWORD+1).EQ.'NUMB'.AND.IARGT(IWORD+2).EQ.'NUMB')GOTO3120 GOTO3110 C 3110 CONTINUE IFOUND='YES' ASUBXL(ISUBID)=CPUMIN ASUBXU(ISUBID)=CPUMAX ASUBYL(ISUBID)=CPUMIN ASUBYU(ISUBID)=CPUMAX 3113 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO3119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3115)ISUBID 3115 FORMAT('THE LIMITS FOR SUB-REGION ',I8,' HAVE JUST BEEN SET') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3117) 3117 FORMAT('TO THE FULL PLOT AREA.') CALL DPWRST('XXX','BUG ') 3119 CONTINUE GOTO9000 C 3120 CONTINUE IFOUND='YES' ASUBXL(ISUBID)=ARG(IWORD+1) ASUBXU(ISUBID)=ARG(IWORD+2) ASUBYL(ISUBID)=ARG(IWORD+1) ASUBYU(ISUBID)=ARG(IWORD+2) IF(ASUBYL(ISUBID).GT.ASUBYU(ISUBID))THEN ATEMP=ASUBYL(ISUBID) ASUBYL(ISUBID)=ASUBYU(ISUBID) ASUBYU(ISUBID)=ATEMP ENDIF IF(ASUBXL(ISUBID).GT.ASUBXU(ISUBID))THEN ATEMP=ASUBXL(ISUBID) ASUBXL(ISUBID)=ASUBXU(ISUBID) ASUBXU(ISUBID)=ATEMP ENDIF C IF(IFEEDB.EQ.'OFF')GOTO3129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3125)ISUBID 3125 FORMAT('THE SUBREGION Y LIMITS FOR SUBREGION ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3126)ASUBYL(ISUBID),ASUBYU(ISUBID) 3126 FORMAT('HAVE JUST BEEN SET TO ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3135)ISUBID 3135 FORMAT('THE SUBREGION X LIMITS FOR SUBREGION ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3126)ASUBXL(ISUBID),ASUBXU(ISUBID) CALL DPWRST('XXX','BUG ') 3129 CONTINUE GOTO9000 C 3199 CONTINUE GOTO9000 C C ******************************************** C ** STEP 81-- ** C ** TREAT THE ? CASE-- ** C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** C ******************************************** C 8100 CONTINUE IFOUND='YES' DO8105I=1,MAXSUB WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111)I 8111 FORMAT('THE CURRENT SUBREGION ',I5,' LIMITS ARE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112)ASUBXL(I),ASUBXU(I) 8112 FORMAT(' --XLIMITS = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8113)ASUBYL(I),ASUBYU(I) 8113 FORMAT(' --YLIMITS = ',2E15.7) CALL DPWRST('XXX','BUG ') 8105 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE DPSBSP(IFOUNO,IOP,XEND,YEND,HEIGHT,WIDTH, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANGLE,AMAX, 1IBUGD2,IERROR) C C PURPOSE--ADJUST XEND, YEND, HEIGHT, AND WIDTH C WHEN ENTERING OR EXITING C SUBSCRIPT OR SUPERSCRIPT MODE. C NOTE--THE INPUT ARGUMENTS XEND, YEND, HEIGHT, AND WIDTH C MAY BE CHANGED BY THIS SUBROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 2001. ALLOW SCALE FACTORS FOR C SIZE OF SUPER/SUB/SCRIPTS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IFOUNO CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IERROR C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOBE.INC' INCLUDE 'DPCOST.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C SUBFAC=0.15 SUPFAC=0.50 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SBSP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSBSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IFOUNO,IOP 52 FORMAT('IFOUNO,IOP = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)XEND,YEND 53 FORMAT('XEND,YEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)HEIGHT,WIDTH 54 FORMAT('HEIGHT,WIDTH = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)SUBFAC,SUPFAC,PSUPXS,PSUPYS 55 FORMAT('SUBFAC,SUPFAC,PSUPXS,PSUPYS = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)PHEIGH,PWIDTH,PVEGAP,PHOGAP 56 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)PHEIG2,PWIDT2,PVEGA2,PHOGA2 57 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)ANGLE,AMAX 58 FORMAT('ANGLE,AMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4 69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C THETA=(ANGLE/AMAX)*2.0*3.1315926 C IF(IFOUNO.EQ.'NO')GOTO1190 C IF(IOP.EQ.'SUB')GOTO1110 IF(IOP.EQ.'UNSB')GOTO1120 IF(IOP.EQ.'SUP')GOTO1130 IF(IOP.EQ.'UNSP')GOTO1140 GOTO1190 C 1110 CONTINUE CCCCC YEND=YEND-SUBFAC*HEIGHT XEND=XEND+SUBFAC*HEIGHT*SIN(THETA) YEND=YEND-SUBFAC*HEIGHT*COS(THETA) CCCCC HEIGHT=HEIGHT/2.0 CCCCC WIDTH=WIDTH/2.0 CCCCC PHEIGH=PHEIGH/2.0 CCCCC PWIDTH=PWIDTH/2.0 CCCCC PVEGAP=PVEGAP/2.0 CCCCC PHOGAP=PHOGAP/2.0 CCCCC PHEIG2=PHEIG2/2.0 CCCCC PWIDT2=PWIDT2/2.0 CCCCC PVEGA2=PVEGA2/2.0 CCCCC PHOGA2=PHOGA2/2.0 HEIGHT=HEIGHT/2.0 WIDTH=WIDTH*PSUPXS PHEIGH=PHEIGH*PSUPYS PWIDTH=PWIDTH*PSUPXS PVEGAP=PVEGAP*PSUPYS PHOGAP=PHOGAP*PSUPXS PHEIG2=PHEIG2*PSUPYS PWIDT2=PWIDT2*PSUPXS PVEGA2=PVEGA2*PSUPYS PHOGA2=PHOGA2*PSUPXS GOTO1190 C 1120 CONTINUE CCCCC HEIGHT=HEIGHT*2.0 CCCCC WIDTH=WIDTH*2.0 CCCCC PHEIGH=PHEIGH*2.0 CCCCC PWIDTH=PWIDTH*2.0 CCCCC PVEGAP=PVEGAP*2.0 CCCCC PHOGAP=PHOGAP*2.0 CCCCC PHEIG2=PHEIG2*2.0 CCCCC PWIDT2=PWIDT2*2.0 CCCCC PVEGA2=PVEGA2*2.0 CCCCC PHOGA2=PHOGA2*2.0 HEIGHT=HEIGHT*(1.0/PSUPYS) WIDTH=WIDTH*(1.0/PSUPXS) PHEIGH=PHEIGH*(1.0/PSUPYS) PWIDTH=PWIDTH*(1.0/PSUPXS) PVEGAP=PVEGAP*(1.0/PSUPYS) PHOGAP=PHOGAP*(1.0/PSUPXS) PHEIG2=PHEIG2*(1.0/PSUPYS) PWIDT2=PWIDT2*(1.0/PSUPXS) PVEGA2=PVEGA2*(1.0/PSUPYS) PHOGA2=PHOGA2*(1.0/PSUPXS) CCCCC YEND=YEND+SUBFAC*HEIGHT XEND=XEND-SUBFAC*HEIGHT*SIN(THETA) YEND=YEND+SUBFAC*HEIGHT*COS(THETA) GOTO1190 C 1130 CONTINUE CCCCC YEND=YEND+SUPFAC*HEIGHT XEND=XEND-SUPFAC*HEIGHT*SIN(THETA) YEND=YEND+SUPFAC*HEIGHT*COS(THETA) CCCCC HEIGHT=HEIGHT/2.0 CCCCC WIDTH=WIDTH/2.0 CCCCC PHEIGH=PHEIGH/2.0 CCCCC PWIDTH=PWIDTH/2.0 CCCCC PVEGAP=PVEGAP/2.0 CCCCC PHOGAP=PHOGAP/2.0 CCCCC PHEIG2=PHEIG2/2.0 CCCCC PWIDT2=PWIDT2/2.0 CCCCC PVEGA2=PVEGA2/2.0 CCCCC PHOGA2=PHOGA2/2.0 HEIGHT=HEIGHT*PSUPYS WIDTH=WIDTH*PSUPXS PHEIGH=PHEIGH*PSUPYS PWIDTH=PWIDTH*PSUPXS PVEGAP=PVEGAP*PSUPYS PHOGAP=PHOGAP*PSUPXS PHEIG2=PHEIG2*PSUPYS PWIDT2=PWIDT2*PSUPXS PVEGA2=PVEGA2*PSUPYS PHOGA2=PHOGA2*PSUPXS GOTO1190 C 1140 CONTINUE CCCCC HEIGHT=HEIGHT*2.0 CCCCC WIDTH=WIDTH*2.0 CCCCC PHEIGH=PHEIGH*2.0 CCCCC PWIDTH=PWIDTH*2.0 CCCCC PVEGAP=PVEGAP*2.0 CCCCC PHOGAP=PHOGAP*2.0 CCCCC PHEIG2=PHEIG2*2.0 CCCCC PWIDT2=PWIDT2*2.0 CCCCC PVEGA2=PVEGA2*2.0 CCCCC PHOGA2=PHOGA2*2.0 HEIGHT=HEIGHT*(1.0/PSUPYS) WIDTH=WIDTH*(1.0/PSUPXS) PHEIGH=PHEIGH*(1.0/PSUPYS) PWIDTH=PWIDTH*(1.0/PSUPXS) PVEGAP=PVEGAP*(1.0/PSUPYS) PHOGAP=PHOGAP*(1.0/PSUPXS) PHEIG2=PHEIG2*(1.0/PSUPYS) PWIDT2=PWIDT2*(1.0/PSUPXS) PVEGA2=PVEGA2*(1.0/PSUPYS) PHOGA2=PHOGA2*(1.0/PSUPXS) CCCCC YEND=YEND-SUPFAC*HEIGHT XEND=XEND+SUPFAC*HEIGHT*SIN(THETA) YEND=YEND-SUPFAC*HEIGHT*COS(THETA) GOTO1190 C 1190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SBSP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSBSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUNO,IOP 9012 FORMAT('IFOUNO,IOP = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)XEND,YEND 9013 FORMAT('XEND,YEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)HEIGHT,WIDTH 9014 FORMAT('HEIGHT,WIDTH = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)SUBFAC,SUPFAC 9015 FORMAT('SUBFAC,SUPFAC = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)PHEIGH,PWIDTH,PVEGAP,PHOGAP 9016 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)PHEIG2,PWIDT2,PVEGA2,PHOGA2 9017 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)ANGLE,AMAX 9018 FORMAT('ANGLE,AMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)THETA 9019 FORMAT('THETA = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSBSW(IHARG,NUMARG,IDEFSB,MAXSUB,ISUBSW, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE SUB-REGION SWITCHES. C THESE ARE LOCATED IN THE VECTOR ISUBSW(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFSB C --MAXSUB C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--ISUBSW (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/11 C ORIGINAL VERSION--NOVEMBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFSB CHARACTER*4 ISUBSW C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 CHARACTER*4 IHOLD2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION ISUBSW(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSB' ISUBN2='SW ' C NUMSUB=0 IHOLD1='-999' IHOLD2='-999' C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSBSW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)MAXSUB,NUMSUB 53 FORMAT('MAXSUB,NUMSUB = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,IHOLD2 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IDEFSB 55 FORMAT('IDEFSB = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I) 66 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)ISUBSW(1) 70 FORMAT('ISUBSW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,ISUBSW(I) 76 FORMAT('I,ISUBSW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 GOTO1130 C 1100 CONTINUE GOTO1200 C 1110 CONTINUE IF(IHARG(1).EQ.'ALL')IHOLD1='OFF' IF(IHARG(1).EQ.'ALL')GOTO1300 GOTO1200 C 1120 CONTINUE IF(IHARG(1).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(1).EQ.'ALL')GOTO1300 IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(1) IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO1210 GOTO1220 C 1210 CONTINUE NUMSUB=1 ISUBSW(1)='ON' GOTO1270 C 1220 CONTINUE NUMSUB=NUMARG IF(NUMSUB.GT.MAXSUB)NUMSUB=MAXSUB DO1225I=1,NUMSUB J=I IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' ISUBSW(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMSUB WRITE(ICOUT,1276)I,ISUBSW(I) 1276 FORMAT('SUBREGION ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSUB=MAXSUB IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' DO1315I=1,NUMSUB ISUBSW(I)=IHOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)ISUBSW(I) 1316 FORMAT('ALL SPIKES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSBSW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)MAXSUB,NUMSUB 9013 FORMAT('MAXSUB,NUMSUB = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,IHOLD2 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IDEFSB 9015 FORMAT('IDEFSB = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I) 9026 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)ISUBSW(1) 9030 FORMAT('ISUBSW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,ISUBSW(I) 9036 FORMAT('I,ISUBSW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSCAN(ISTART,ISTRIN,NUMCHS,ILOCR2, 1ICHAR2,IOP,IFONT,ICASE,IJUST,ISEQUE,ISUBSU, 1HMAX,VMAX,AMAX,X0,Y0,ANGLE,WIDTH,HEIGHT, 1IEND,IFOUNC,IFOUNO,IBUGD2,IERROR) C C PURPOSE--SCAN THE STRING IN ISTRIN(.) STARTING WITH POSITION ISTART. C EXAMINE THE NEXT 6 CHARACTERS AT MOST. C COPY AND PACK THE NEXT 4 CHARACTERS INTO IWORD1. C IF () FOUND IN NEXT 6 CHARACTERS, THEN STRIP OFF () C AND SAVE PREVIOUS INTO IWORD1 (PACKED). C | IF() NOT FOUND, THEN OUTPUT A SINGLE CHARACTER IN IWORD1. 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 1981. C UPDATED --OCTOBER 1981. C UPDATED --MAY 1982. C UPDATED --APRIL 1987. C UPDATED --AUGUST 1992. ADDITIONAL SYMBOLS C UPDATED --FEBRUARY 1995. CONVERT IWORD1 TO UPPER CASE C (CASE ASIS COMPLICATION) C UPDATED --NOVEMBER 1996. COMPILE ERROR FOR LINIX G77 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISTRIN CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IFONT CHARACTER*4 ICASE CHARACTER*4 IJUST CHARACTER*4 ISEQUE CHARACTER*4 ISUBSU CHARACTER*4 IFOUNC CHARACTER*4 IFOUNO CHARACTER*4 IBUGD2 CHARACTER*4 IERROR C CHARACTER*4 IWORD1 CHARACTER*4 IXXXXX CHARACTER*4 IFOULR CHARACTER*4 IOPERT CHARACTER*4 IGREET CHARACTER*4 IMATHT C CCCCC CHARACTER*4 ICHAR3 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION ISTRIN(*) C DIMENSION IOPERT(50) DIMENSION IGREET(25) DIMENSION IMATHT(200) C DIMENSION IOPERN(50) DIMENSION IGREEN(25) DIMENSION IMATHN(200) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C ************************* C ** DEFINE OPERATIONS ** C ************************* C DATA IOPERT( 1) /'SIMP'/ DATA IOPERT( 2) /'DUPL'/ DATA IOPERT( 3) /'TRIP'/ DATA IOPERT( 4) /'COMP'/ DATA IOPERT( 5) /'TRII'/ DATA IOPERT( 6) /'COMI'/ DATA IOPERT( 7) /'SIMS'/ DATA IOPERT( 8) /'COMS'/ C DATA IOPERT( 9) /'UC '/ DATA IOPERT(10) /'CAP '/ DATA IOPERT(11) /'CAPS'/ DATA IOPERT(12) /'LC '/ C DATA IOPERT(13) /'LJUS'/ DATA IOPERT(14) /'CJUS'/ DATA IOPERT(15) /'RJUS'/ C DATA IOPERT(16) /'SEQ '/ DATA IOPERT(17) /'UNSQ'/ C DATA IOPERT(18) /'SUB '/ DATA IOPERT(19) /'UNSB'/ DATA IOPERT(20) /'SUP '/ DATA IOPERT(21) /'UNSP'/ C DATA IOPERT(22) /'HMAX'/ DATA IOPERT(23) /'VMAX'/ DATA IOPERT(24) /'ANGL'/ DATA IOPERT(25) /'HEIG'/ DATA IOPERT(26) /'WIDT'/ DATA IOPERT(27) /'ANGL'/ C DATA IOPERT(28) /'MOVE'/ DATA IOPERT(29) /'DRAW'/ DATA IOPERT(30) /'RELM'/ DATA IOPERT(31) /'RELD'/ C DATA IOPERT(32) /'BACK'/ DATA IOPERT(33) /'OVER'/ DATA IOPERT(34) /'UP '/ DATA IOPERT(35) /'DOWN'/ DATA IOPERT(36) /'TAB '/ DATA IOPERT(37) /'RETU'/ C C ******************************* C ** DEFINE GREEK CHARACTERS ** C ******************************* C DATA IGREET( 1) /'ALPH'/ DATA IGREET( 2) /'BETA'/ DATA IGREET( 3) /'GAMM'/ DATA IGREET( 4) /'DELT'/ DATA IGREET( 5) /'EPSI'/ DATA IGREET( 6) /'ZETA'/ DATA IGREET( 7) /'ETA '/ DATA IGREET( 8) /'THET'/ DATA IGREET( 9) /'IOTA'/ DATA IGREET(10) /'KAPP'/ DATA IGREET(11) /'LAMB'/ DATA IGREET(12) /'MU '/ DATA IGREET(13) /'NU '/ DATA IGREET(14) /'XI '/ DATA IGREET(15) /'OMIC'/ DATA IGREET(16) /'PI '/ DATA IGREET(17) /'RHO '/ DATA IGREET(18) /'SIGM'/ DATA IGREET(19) /'TAU '/ DATA IGREET(20) /'UPSI'/ DATA IGREET(21) /'PHI '/ DATA IGREET(22) /'CHI '/ DATA IGREET(23) /'PSI '/ DATA IGREET(24) /'OMEG'/ C C *************************** C ** DEFINE MATH SYMBOLS ** C *************************** C DATA IMATHT( 1) /'HASP'/ DATA IMATHT( 2) /'SPAC'/ DATA IMATHT( 3) /'SP '/ DATA IMATHT( 4) /'LAPO'/ DATA IMATHT( 5) /'RAPO'/ DATA IMATHT( 6) /'LBRA'/ DATA IMATHT( 7) /'RBRA'/ DATA IMATHT( 8) /'LCBR'/ DATA IMATHT( 9) /'RCBR'/ DATA IMATHT(10) /'LELB'/ DATA IMATHT(11) /'RELB'/ DATA IMATHT(12) /'+- '/ DATA IMATHT(13) /'-+ '/ DATA IMATHT(14) /'TIME'/ DATA IMATHT(15) /'DOTP'/ DATA IMATHT(16) /'DIVI'/ DATA IMATHT(17) /'NOT='/ DATA IMATHT(18) /'EQUI'/ DATA IMATHT(19) /'LT '/ DATA IMATHT(20) /'GT '/ DATA IMATHT(21) /'LTEQ'/ DATA IMATHT(22) /'GTEQ'/ DATA IMATHT(23) /'VARI'/ DATA IMATHT(24) /'APPR'/ DATA IMATHT(25) /'TILD'/ DATA IMATHT(26) /'CARA'/ DATA IMATHT(27) /'RACC'/ DATA IMATHT(28) /'PRIM'/ DATA IMATHT(29) /'LACC'/ DATA IMATHT(30) /'BREV'/ DATA IMATHT(31) /'RQUO'/ DATA IMATHT(32) /'LQUO'/ DATA IMATHT(33) /'NASP'/ DATA IMATHT(34) /'IASP'/ DATA IMATHT(35) /'RADI'/ DATA IMATHT(36) /'LRAD'/ DATA IMATHT(37) /'BRAD'/ DATA IMATHT(38) /'SUBS'/ DATA IMATHT(39) /'SUPE'/ DATA IMATHT(40) /'UNIO'/ DATA IMATHT(41) /'INTR'/ DATA IMATHT(42) /'ELEM'/ DATA IMATHT(43) /'RARR'/ DATA IMATHT(44) /'LARR'/ DATA IMATHT(45) /'UARR'/ DATA IMATHT(46) /'DARR'/ DATA IMATHT(47) /'PART'/ DATA IMATHT(48) /'INTE'/ DATA IMATHT(49) /'CINT'/ DATA IMATHT(50) /'SUMM'/ DATA IMATHT(51) /'PROD'/ DATA IMATHT(52) /'INFI'/ DATA IMATHT(53) /'PARA'/ DATA IMATHT(54) /'DAGG'/ DATA IMATHT(55) /'DDAG'/ DATA IMATHT(56) /'THEX'/ DATA IMATHT(57) /'THFO'/ DATA IMATHT(58) /'VBAR'/ DATA IMATHT(59) /'DVBA'/ DATA IMATHT(60) /'LVBA'/ DATA IMATHT(61) /'HBAR'/ DATA IMATHT(62) /'LHBA'/ DATA IMATHT(63) /'HHBA'/ DATA IMATHT(64) /'BAR '/ DATA IMATHT(65) /'DEL '/ C DATA IMATHT(66) /'ZZZZ'/ DATA IMATHT(67) /'ZZZZ'/ DATA IMATHT(68) /'ZZZZ'/ DATA IMATHT(69) /'ZZZZ'/ DATA IMATHT(70) /'ZZZZ'/ C DATA IMATHT(71) /'. '/ DATA IMATHT(72) /'POIN'/ DATA IMATHT(73) /'PO '/ DATA IMATHT(74) /'PT '/ DATA IMATHT(75) /'CIRC'/ DATA IMATHT(76) /'CI '/ DATA IMATHT(77) /'SQUA'/ DATA IMATHT(78) /'SQ '/ DATA IMATHT(79) /'TRIA'/ DATA IMATHT(80) /'TR '/ DATA IMATHT(81) /'DIAM'/ DATA IMATHT(82) /'DI '/ DATA IMATHT(83) /'STAR'/ DATA IMATHT(84) /'ST '/ DATA IMATHT(85) /'* '/ DATA IMATHT(86) /'ASTE'/ DATA IMATHT(87) /'AS '/ DATA IMATHT(88) /'TRIR'/ DATA IMATHT(89) /'TRII'/ DATA IMATHT(90) /'BARU'/ DATA IMATHT(91) /'BU '/ DATA IMATHT(92) /'BARV'/ DATA IMATHT(93) /'BV '/ DATA IMATHT(94) /'BARH'/ DATA IMATHT(95) /'BH '/ DATA IMATHT(96) /'ARRU'/ DATA IMATHT(97) /'AU '/ DATA IMATHT(98) /'ARRD'/ DATA IMATHT(99) /'AD '/ DATA IMATHT(100) /'ARRL'/ DATA IMATHT(101) /'AL '/ DATA IMATHT(102) /'ARRR'/ DATA IMATHT(103) /'AR '/ CCCCC NOVEMBER 1996. FOLLOWING LINE CAUSES COMPILE ERROR ON LINUX CCCCC G77 COMPILER. CLINX DATA IMATHT(104) /'\ '/ DATA IMATHT(105) /'BASL'/ DATA IMATHT(106) /'BACK'/ DATA IMATHT(107) /'BS '/ DATA IMATHT(108) /'_ '/ DATA IMATHT(109) /'UNDE'/ DATA IMATHT(110) /'CUBE'/ DATA IMATHT(111) /'PYRA'/ C AUGUST 1992. ADD REVT, RT (FOR REVERSE TRIANGLE, TO AGREE WITH C DOCUMENTATION), AND ARRO, ARRH, VECT FOR THE ARROW COMMAND DATA IMATHT(112) /'REVT'/ DATA IMATHT(113) /'RT '/ DATA IMATHT(114) /'ARRO'/ DATA IMATHT(115) /'ARRH'/ DATA IMATHT(116) /'VECT'/ DATA IMATHT(117) /'DEGR'/ C C--------------------------------------------------------------------- C C ****************************************************** C ** DEFINE THE NUMBER OF CHARACTERS FOR OPERATIONS ** C ****************************************************** C DATA IOPERN( 1) /4/ DATA IOPERN( 2) /4/ DATA IOPERN( 3) /4/ DATA IOPERN( 4) /4/ DATA IOPERN( 5) /4/ DATA IOPERN( 6) /4/ DATA IOPERN( 7) /4/ DATA IOPERN( 8) /4/ C DATA IOPERN( 9) /2/ DATA IOPERN(10) /3/ DATA IOPERN(11) /4/ DATA IOPERN(12) /2/ C DATA IOPERN(13) /4/ DATA IOPERN(14) /4/ DATA IOPERN(15) /4/ C DATA IOPERN(16) /3/ DATA IOPERN(17) /4/ C DATA IOPERN(18) /3/ DATA IOPERN(19) /4/ DATA IOPERN(20) /3/ DATA IOPERN(21) /4/ C DATA IOPERN(22) /4/ DATA IOPERN(23) /4/ DATA IOPERN(24) /4/ DATA IOPERN(25) /4/ DATA IOPERN(26) /4/ DATA IOPERN(27) /4/ C DATA IOPERN(28) /4/ DATA IOPERN(29) /4/ DATA IOPERN(30) /4/ DATA IOPERN(31) /4/ C DATA IOPERN(32) /4/ DATA IOPERN(33) /4/ DATA IOPERN(34) /2/ DATA IOPERN(35) /4/ DATA IOPERN(36) /3/ DATA IOPERN(37) /4/ C C ************************************************************ C ** DEFINE THE NUMBER OF CHARACTERS FOR GREEK CHARACTERS ** C ************************************************************ C DATA IGREEN( 1) /4/ DATA IGREEN( 2) /4/ DATA IGREEN( 3) /4/ DATA IGREEN( 4) /4/ DATA IGREEN( 5) /4/ DATA IGREEN( 6) /4/ DATA IGREEN( 7) /3/ DATA IGREEN( 8) /4/ DATA IGREEN( 9) /4/ DATA IGREEN(10) /4/ DATA IGREEN(11) /4/ DATA IGREEN(12) /2/ DATA IGREEN(13) /2/ DATA IGREEN(14) /2/ DATA IGREEN(15) /4/ DATA IGREEN(16) /2/ DATA IGREEN(17) /3/ DATA IGREEN(18) /4/ DATA IGREEN(19) /3/ DATA IGREEN(20) /4/ DATA IGREEN(21) /3/ DATA IGREEN(22) /3/ DATA IGREEN(23) /3/ DATA IGREEN(24) /4/ C C ******************************************************** C ** DEFINE THE NUMBER OF CHARACTERS FOR MATH SYMBOLS ** C ******************************************************** C DATA IMATHN( 1) /4/ DATA IMATHN( 2) /4/ DATA IMATHN( 3) /2/ DATA IMATHN( 4) /4/ DATA IMATHN( 5) /4/ DATA IMATHN( 6) /4/ DATA IMATHN( 7) /4/ DATA IMATHN( 8) /4/ DATA IMATHN( 9) /4/ DATA IMATHN(10) /4/ DATA IMATHN(11) /4/ DATA IMATHN(12) /2/ DATA IMATHN(13) /2/ DATA IMATHN(14) /4/ DATA IMATHN(15) /4/ DATA IMATHN(16) /4/ DATA IMATHN(17) /4/ DATA IMATHN(18) /4/ DATA IMATHN(19) /2/ DATA IMATHN(20) /2/ DATA IMATHN(21) /4/ DATA IMATHN(22) /4/ DATA IMATHN(23) /4/ DATA IMATHN(24) /4/ DATA IMATHN(25) /4/ DATA IMATHN(26) /4/ DATA IMATHN(27) /4/ DATA IMATHN(28) /4/ DATA IMATHN(29) /4/ DATA IMATHN(30) /4/ DATA IMATHN(31) /4/ DATA IMATHN(32) /4/ DATA IMATHN(33) /4/ DATA IMATHN(34) /4/ DATA IMATHN(35) /4/ DATA IMATHN(36) /4/ DATA IMATHN(37) /4/ DATA IMATHN(38) /4/ DATA IMATHN(39) /4/ DATA IMATHN(40) /4/ DATA IMATHN(41) /4/ DATA IMATHN(42) /4/ DATA IMATHN(43) /4/ DATA IMATHN(44) /4/ DATA IMATHN(45) /4/ DATA IMATHN(46) /4/ DATA IMATHN(47) /4/ DATA IMATHN(48) /4/ DATA IMATHN(49) /4/ DATA IMATHN(50) /4/ DATA IMATHN(51) /4/ DATA IMATHN(52) /4/ DATA IMATHN(53) /4/ DATA IMATHN(54) /4/ DATA IMATHN(55) /4/ DATA IMATHN(56) /4/ DATA IMATHN(57) /4/ DATA IMATHN(58) /4/ DATA IMATHN(59) /4/ DATA IMATHN(60) /4/ DATA IMATHN(61) /4/ DATA IMATHN(62) /4/ DATA IMATHN(63) /4/ DATA IMATHN(64) /3/ DATA IMATHN(65) /3/ C DATA IMATHN(66) /4/ DATA IMATHN(67) /4/ DATA IMATHN(68) /4/ DATA IMATHN(69) /4/ DATA IMATHN(70) /4/ C DATA IMATHN(71) /1/ DATA IMATHN(72) /4/ DATA IMATHN(73) /2/ DATA IMATHN(74) /2/ DATA IMATHN(75) /4/ DATA IMATHN(76) /2/ DATA IMATHN(77) /4/ DATA IMATHN(78) /2/ DATA IMATHN(79) /4/ DATA IMATHN(80) /2/ DATA IMATHN(81) /4/ DATA IMATHN(82) /2/ DATA IMATHN(83) /4/ DATA IMATHN(84) /2/ DATA IMATHN(85) /1/ DATA IMATHN(86) /4/ DATA IMATHN(87) /2/ DATA IMATHN(88) /4/ DATA IMATHN(89) /4/ DATA IMATHN(90) /4/ DATA IMATHN(91) /2/ DATA IMATHN(92) /4/ DATA IMATHN(93) /2/ DATA IMATHN(94) /4/ DATA IMATHN(95) /2/ DATA IMATHN(96) /4/ DATA IMATHN(97) /2/ DATA IMATHN(98) /4/ DATA IMATHN(99) /2/ DATA IMATHN(100) /4/ DATA IMATHN(101) /2/ DATA IMATHN(102) /4/ DATA IMATHN(103) /2/ DATA IMATHN(104) /1/ DATA IMATHN(105) /4/ DATA IMATHN(106) /4/ DATA IMATHN(107) /2/ DATA IMATHN(108) /1/ DATA IMATHN(109) /4/ DATA IMATHN(110) /4/ DATA IMATHN(111) /4/ C C AUGUST 1992. ADDED FOLLOWING LINES FOR REVERSE TRIANGLE SYNONYMS C AND FOR ARROW. C DATA IMATHN(112) /4/ DATA IMATHN(113) /2/ DATA IMATHN(114) /4/ DATA IMATHN(115) /4/ DATA IMATHN(116) /4/ DATA IMATHN(117) /4/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPSC' ISUBN2='AN ' C IFOUNO='NO' IFOUNC='NO' IERROR='NO' C CLINX NOVEMBER 1996. FOLLOWING TO ACCOMODATE LINUX G77 COMPILER. CALL DPCONA(92,IMATHT(104)) J2=0 NUMC=0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCAN')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSCAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISTART,ISTRIN(ISTART),NUMCHS,ILOCR2 52 FORMAT('ISTART,ISTRIN(ISTART),NUMCHS,ILOCR2 = ',I8,2X,A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)(ISTRIN(I),I=1,NUMCHS) 53 FORMAT('(ISTRIN(I),I=1,NUMCHS) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4 59 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************************* C ** STEP 2-- ** C ** PACK THE PRESENT CHARACTER ** C ** AND THE NEXT 3 CHARACTERS INTO ** C ** THE SINGLE COMPUTER WORD IWORD1. ** C ** IF A LEFT PARENTHESIS IS ENCOUNTERED, ** C ** STOP THE PACK ** C ** (AND EXCLUDE THE LEFT PARENTHESIS ** C ** FROM THE PACK). ** C ********************************************* C ISTEPN='2' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWORD1=' ' C ISTAR1=0 ILEN1=NUMBPC ILEN2=NUMBPC C DO1100K=1,4 L=ISTART+K-1 IF(L.GT.NUMCHS)GOTO1190 IF(ISTRIN(L).EQ.'(')GOTO1190 ISTAR2=NUMBPC*(K-1) CALL DPCHEX(ISTAR1,ILEN1,ISTRIN(L),ISTAR2,ILEN2,IWORD1) 1100 CONTINUE 1190 CONTINUE CCCCC CONVERT IWORD1 TO UPPER CASE. FEBRUARY 1995. DO1191I=1,4 CALL DPCOAN(IWORD1(I:I),IVALT) IF(IVALT.GE.97.AND.IVALT.LE.122)IVALT=IVALT-32 CALL DPCONA(IVALT,IWORD1(I:I)) 1191 CONTINUE C C ************************************************************* C ** STEP 1--CHECK TO SEE ** C ** IF BEYOND THE RIGHTMOST RIGHT PARENTHESIS ** C ** (WHICH IMPLIES THAT ALL SUBSEQUENT CHARACTERS ** C ** ARE ONLY 1 CHARACTER LONG). ** C ************************************************************* C IF(ISTART.GT.ILOCR2)GOTO6000 C C *************************** C ** STEP 3.1-- ** C ** CHECK FOR FONT TYPE ** C *************************** C 2100 CONTINUE ISTEPN='3.1' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=1 JMAX=8 DO2110J=JMIN,JMAX J2=J IF(IWORD1.EQ.IOPERT(J))GOTO2150 2110 CONTINUE GOTO2190 2150 CONTINUE NUMC=IOPERN(J2) ILOCLP=ISTART+NUMC ILOCRP=ISTART+NUMC+1 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) IF(IFOULR.EQ.'YES')GOTO2160 GOTO2190 2160 CONTINUE IFONT=IWORD1 IEND=ILOCRP IOP=IFONT IFOUNO='YES' GOTO9000 2190 CONTINUE C C ********************************** C ** STEP 3.2-- ** C ** CHECK FOR UPPER/LOWER CASE ** C ********************************** C 2200 CONTINUE ISTEPN='3.2' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C JMIN=9 JMAX=12 DO2210J=JMIN,JMAX J2=J IF(IWORD1.EQ.IOPERT(J))GOTO2250 2210 CONTINUE GOTO2290 2250 CONTINUE NUMC=IOPERN(J2) ILOCLP=ISTART+NUMC ILOCRP=ISTART+NUMC+1 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) IF(IFOULR.EQ.'YES')GOTO2260 GOTO2290 2260 CONTINUE ICASE=IWORD1 IF(ICASE.EQ.'LC')ICASE='LOWE' IF(ICASE.EQ.'LCAS')ICASE='LOWE' IF(ICASE.EQ.'UC')ICASE='UPPE' IF(ICASE.EQ.'UCAS')ICASE='UPPE' IF(ICASE.EQ.'CAPS')ICASE='UPPE' IF(ICASE.EQ.'CAP')ICASE='UPPE' IEND=ILOCRP IOP=ICASE IFOUNO='YES' GOTO9000 2290 CONTINUE C C ************************************************* C ** STEP 3.3-- ** C ** CHECK FOR LEFT/CENTER/RIGHT JUSTIFICATION ** C ************************************************* C 2300 CONTINUE ISTEPN='3.3' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=13 JMAX=15 DO2310J=JMIN,JMAX J2=J IF(IWORD1.EQ.IOPERT(J))GOTO2350 2310 CONTINUE GOTO2390 2350 CONTINUE NUMC=IOPERN(J2) ILOCLP=ISTART+NUMC ILOCRP=ISTART+NUMC+1 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) IF(IFOULR.EQ.'YES')GOTO2360 GOTO2390 2360 CONTINUE IJUST=IWORD1 IEND=ILOCRP IOP=IJUST IFOUNO='YES' GOTO9000 2390 CONTINUE C C ****************************************** C ** STEP 3.4-- ** C ** CHECK FOR SEQUENCE/UNSEQUENCE CASE ** C ****************************************** C 2400 CONTINUE ISTEPN='3.4' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=16 JMAX=17 DO2410J=JMIN,JMAX J2=J IF(IWORD1.EQ.IOPERT(J))GOTO2450 2410 CONTINUE GOTO2490 2450 CONTINUE NUMC=IOPERN(J2) ILOCLP=ISTART+NUMC ILOCRP=ISTART+NUMC+1 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) IF(IFOULR.EQ.'YES')GOTO2460 GOTO2490 2460 CONTINUE ISEQUE=IWORD1 IEND=ILOCRP IOP=ISEQUE IFOUNO='YES' GOTO9000 2490 CONTINUE C C ******************************************** C ** STEP 3.5-- ** C ** CHECK FOR SUBSCRIPT/SUPERSCRIPT CASE ** C ******************************************** C 2500 CONTINUE ISTEPN='3.5' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=18 JMAX=21 DO2510J=JMIN,JMAX J2=J IF(IWORD1.EQ.IOPERT(J))GOTO2550 2510 CONTINUE GOTO2590 2550 CONTINUE NUMC=IOPERN(J2) ILOCLP=ISTART+NUMC ILOCRP=ISTART+NUMC+1 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) IF(IFOULR.EQ.'YES')GOTO2560 GOTO2590 2560 CONTINUE ISUBSU=IWORD1 IEND=ILOCRP IOP=ISUBSU IFOUNO='YES' GOTO9000 2590 CONTINUE C C **************************************** C ** STEP 3.6-- ** C ** CHECK FOR SCREEN MAX, ANGLE MAX, ** C ** HEIGHT, WIDTH, AND ANGLE. ** C **************************************** C 2600 CONTINUE ISTEPN='3.6' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=22 JMAX=27 DO2610J=JMIN,JMAX J2=J IF(IWORD1.EQ.IOPERT(J))GOTO2650 2610 CONTINUE GOTO2690 2650 CONTINUE NUMC=IOPERN(J2) ILOCLP=ISTART+NUMC ILOCRP=ISTART+NUMC+1 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) IF(IFOULR.EQ.'YES')GOTO2660 GOTO2690 2660 CONTINUE IXXXXX=IWORD1 IEND=ILOCRP IOP=IXXXXX IFOUNO='YES' GOTO9000 2690 CONTINUE C C ********************************************* C ** STEP 3.7-- ** C ** CHECK FOR MOVE, DRAW, ETC. OPERATIONS ** C ********************************************* C 2700 CONTINUE ISTEPN='3.7' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=28 JMAX=37 DO2710J=JMIN,JMAX J2=J IF(IWORD1.EQ.IOPERT(J))GOTO2750 2710 CONTINUE GOTO2790 2750 CONTINUE NUMC=IOPERN(J2) ILOCLP=ISTART+NUMC ILOCRP=ISTART+NUMC+1 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) IF(IFOULR.EQ.'YES')GOTO2760 GOTO2790 2760 CONTINUE IXXXXX=IWORD1 IEND=ILOCRP IOP=IXXXXX IFOUNO='YES' GOTO9000 2790 CONTINUE C C ********************************** C ** STEP 3.8-- ** C ** CHECK FOR GREEK CHARACTERS ** C ********************************** C 3100 CONTINUE ISTEPN='3.8' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=1 JMAX=24 DO3110J=JMIN,JMAX J2=J IF(IWORD1.EQ.IGREET(J))GOTO3150 3110 CONTINUE GOTO3190 3150 CONTINUE NUMC=IGREEN(J2) ILOCLP=ISTART+NUMC ILOCRP=ISTART+NUMC+1 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) IF(IFOULR.EQ.'YES')GOTO3160 GOTO3190 3160 CONTINUE ICHAR2=IWORD1 IEND=ILOCRP IFOUNC='YES' GOTO9000 3190 CONTINUE C C ****************************** C ** STEP 3.9-- ** C ** CHECK FOR MATH SYMBOLS ** C ****************************** C 4100 CONTINUE ISTEPN='3.9' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=1 CCCCC JMAX=109 CCCCC JMAX=111 JMAX=117 DO4110J=JMIN,JMAX J2=J IF(IWORD1.EQ.IMATHT(J))GOTO4150 4110 CONTINUE GOTO4190 4150 CONTINUE NUMC=IMATHN(J2) ILOCLP=ISTART+NUMC ILOCRP=ISTART+NUMC+1 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) IF(IFOULR.EQ.'YES')GOTO4160 GOTO4190 4160 CONTINUE ICHAR2=IWORD1 IEND=ILOCRP IFOUNC='YES' GOTO9000 4190 CONTINUE C C ************************************************* C ** STEP 4-- ** C ** NO MATCH FOUND FOR ANY OF THE ABOVE; ** C ** THEREFORE OUTPUT ONLY THE LEAD CHARACTER. ** C ************************************************* C C 6000 CONTINUE ISTEPN='4' IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMCHS.LE.1)GOTO6005 ILOCLP=ISTART ILOCRP=ISTART+1 IF(ISTRIN(ILOCLP).EQ.'('.AND.ISTRIN(ILOCRP).EQ.')')GOTO6006 6005 CONTINUE ICHAR2=ISTRIN(ISTART) IEND=ISTART IFOUNC='YES' GOTO9000 6006 CONTINUE IEND=ILOCRP IFOUNO='YES' GOTO9000 C C PRE-1986--THE FOLLOWING COMMENTED-OUT CODE WAS FOR PUTTING OUT C UP TO 4 CHARACTERS AS A PLOT CHARACTER C AND THEREFORE COMMENTED OUT. C CCCCC DO6010I=1,4 CCCCC I2=I CCCCC ICHAR3=' ' CCCCC ICHAR3(1:1)=IWORD1(I:I) CCCCC IF(ICHAR3.EQ.'(')GOTO6020 CCCCC IF(ICHAR3.EQ.' ')GOTO6020 C6010 CONTINUE CCCCC NUMC=I2 CCCCC GOTO6080 C6020 CONTINUE CCCCC NUMC=I2-1 CCCCC GOTO6080 C6080 CONTINUE CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCAN')GOTO6089 CCCCC WRITE(ICOUT,6081) C6081 FORMAT('***** FROM THE MIDDLE OF DPSCAN--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,6082)IWORD1,ICHAR3 C6082 FORMAT('IWORD1,ICHAR3 = ',A4,2X,A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,6083)I2,NUMC C6083 FORMAT('I2,NUMC = ',2I8) CCCCC CALL DPWRST('XXX','BUG ') C6089 CONTINUE C6090 CONTINUE CCCCC ILOCLP=ISTART+NUMC CCCCC ILOCRP=ISTART+NUMC+1 CCCCC CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) CCCCC IF(IFOULR.EQ.'YES')GOTO6095 CCCCC GOTO6097 C6095 CONTINUE CCCCC ICHAR2=IWORD1 CCCCC IEND=ILOCRP CCCCC IFOUNC='YES' CCCCC GOTO9000 C6097 CONTINUE CCCCC ICHAR2=ISTRIN(ISTART) CCCCC IEND=ISTART CCCCC IFOUNC='YES' CCCCC GOTO9000 C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCAN')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSCAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUNC,IFOUNO,IBUGD2,IERROR 9012 FORMAT('IFOUNC,IFOUNO,IBUGD2,IERROR = ', 1A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,IOP,ISTART,IEND 9013 FORMAT('ICHAR2,IOP,ISTART,IEND = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IFONT,ICASE,IJUST,ISEQUE,ISUBSU 9014 FORMAT('IFONT,ICASE,IJUST,ISEQUE,ISUBSU = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)HMAX,VMAX,AMAX 9015 FORMAT('HMAX,VMAX,AMAX = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)X0,Y0,ANGLE 9016 FORMAT('X0,Y0,ANGLE = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)WIDTH,HEIGHT 9017 FORMAT('WIDTH,HEIGHT = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)ISTAR2,IWORD1,NUMC,J2 9018 FORMAT('ISTAR2,IWORD1,NUMC,J2 = ',I8,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IBUGG4,ISUBG4 9019 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSCEB(Y1,Y2,Y3,NPTS,NLAB, 1W,N, 1AMEAN,ASD,S2BMPS, 1XSE,XSES2,IDFH,SIGMAH, 1SESUK1,SESUK2, 1DLOWSE,DHIGSE, 1IWRITE, 1ICAPSW,ICAPTY, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--IMPLEMENT SCHILLER-EBERHARDT APPROACH TO C CONSENSUS MEANS C PRINTING--YES C SUBROUTINES NEEDED--NONE C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. EXTRACTED FROM DPMAN2 ROUTINE C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------- C IMPLICIT DOUBLE PRECISION (A-H, O-Z) C CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 ISUBRO CHARACTER*4 ISUBN0 CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*1 IBASLC C CHARACTER*20 IMETH C REAL APPF REAL XSE REAL XSES2 REAL S2BMPS REAL SIGMAH REAL SESUK1 REAL SESUK2 C C---------------------------------------------------------------- C REAL Y1(*) REAL Y2(*) REAL Y3(*) REAL AMEAN(*) REAL ASD(*) C INTEGER N(*) C DOUBLE PRECISION W(*) C INCLUDE 'DPCOST.INC' C PARAMETER (MAXHED=50) INTEGER IWIDTH(MAXHED) INTEGER NUMDI2(MAXHED) CHARACTER*8 ALIGN(MAXHED) CHARACTER*8 VALIGN(MAXHED) COMMON/HTML4/IWIDTH,NUMDI2,ALIGN,VALIGN CHARACTER*45 IVALUE(MAXHED) INTEGER NCHAR(MAXHED) REAL AVALUE(MAXHED) C LOGICAL IFLAG1 LOGICAL IFLAG2 LOGICAL IFLAG3 C CHARACTER*132 ITTEMP CHARACTER*132 IHEAD C CHARACTER*4 IRTFMD COMMON/COMRTF/IRTFMD C REAL CPUMIN REAL CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------ C IERROR='NO' C ISUBN1='DPVR' ISUBN2='ML ' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SCEB')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSCEB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPTS,NLAB 52 FORMAT('NPTS,NLAB = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,NPTS WRITE(ICOUT,56)I,Y1(I),Y2(I),Y3(I) 56 FORMAT('I,Y1(I),Y2(I),Y3(I) = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE ENDIF C DSUM1=0.0D0 DO810I=1,NLAB DVAR=DBLE(ASD(I))**2 W(I)=1.0D0/(DVAR+DBLE(S2BMPS)) DSUM1=DSUM1 + W(I) 810 CONTINUE DWTSUM=DSUM1 DSUM1=0.0D0 DSUM2=0.0D0 DSUM3=0.0D0 DO815I=1,NLAB DVAR=DBLE(ASD(I))**2 W(I)=W(I)/DWTSUM XI=DBLE(AMEAN(I)) DSUM1=DSUM1 + W(I)*XI DSUM2=DSUM2 + W(I)*DVAR DSUM3=DSUM3 + (W(I)*DVAR)**2/DBLE(N(I)-1.0D0) 815 CONTINUE XSE=REAL(DSUM1) ADFH=REAL(IDFH) DTERM1=(DSUM2 + SIGMAH**2)**2 DTERM2=(DSUM3 + SIGMAH**4/ADFH) ADF=REAL(DTERM1/DTERM2) IDF=INT(ADF+0.5) C DSUM1=0.0D0 DO820I=1,NLAB DVAR=DBLE(ASD(I))**2 W(I)=1.0D0/DVAR DSUM1=DSUM1 + W(I) 820 CONTINUE DWTSUM=DSUM1 DSUM1=0.0D0 DO825I=1,NLAB DTERM1=(W(I)/DWTSUM)**2 DSUM1=DSUM1 + DTERM1*DBLE(ASD(I)**2) 825 CONTINUE XSES2=REAL(DSUM1) C DBIAS=0.0D0 DO830I=1,NLAB XI=DBLE(AMEAN(I)) DTERM1=DABS(XI-DBLE(XSE)) IF(DTERM1.GT.DBIAS)DBIAS=DTERM1 830 CONTINUE C CALL TPPF(0.975,REAL(IDF),APPF) DSESU1=SQRT(DBLE(XSES2) + DBLE(SIGMAH)**2) + DBIAS DSESU2=2.0D0*SQRT(DBLE(XSES2) + DBLE(SIGMAH)**2) + DBIAS DSEU=DBLE(APPF)*SQRT(DBLE(XSES2) + DBLE(SIGMAH)**2) + DBIAS DLOWSE=DBLE(XSE) - DSEU DHIGSE=DBLE(XSE) + DSEU ABIAS=REAL(DBIAS) ISEDF=IDF SESUK1=REAL(DSESU1) SESUK2=REAL(DSESU2) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C WRITE(ICOUT,5107) 5107 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5111) 5111 FORMAT('') CALL DPWRST('XXX','WRIT') C 5121 FORMAT(' ') 5123 FORMAT(' ') 5126 FORMAT(' ') 5151 FORMAT(' ',I8) 5152 FORMAT(' ',F15.7) 5155 FORMAT('  ') 5191 FORMAT('
    ') 5127 FORMAT(' ') 5128 FORMAT('
    ') 5193 FORMAT('
') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5170) 5170 FORMAT(' 5. Method: Schiller-Eberhardt:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5171) 5171 FORMAT('      ', 1 'Estimate of Consensus Mean:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XSE CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5173) 5173 FORMAT('      ', 1 'Estimate of Variance of Mean:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XSES2 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5174) 5174 FORMAT('      ', 1 'Bias Allowance:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)ABIAS CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5175) 5175 FORMAT('      ', 1 'Sigmah (heterogeneity):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)SIGMAH CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5176) 5176 FORMAT('      ', 1 'Degrees of Freedom for Sigmah:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5151)IDFH CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5177) 5177 FORMAT('      ', 1 'Standard Uncertainty (k = 1):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)DSESU1 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5178) 5178 FORMAT('      ', 1 'Expanded Uncertainty (k = 2):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)DSESU2 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5179)APPF 5179 FORMAT('      ', 1 'Expanded Uncertainty (k = ',F10.7,'):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)DSEU CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5181) 5181 FORMAT('      ', 1 'Degrees of Freedom:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5151)IDF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5182) 5182 FORMAT('      ', 1 't Percent Point Value (alpha = 0.05:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)APPF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5183) 5183 FORMAT('      ', 1 'Lower 95% Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DLOWSE) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5184) 5184 FORMAT('      ', 1 'Upper 95% Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DHIGSE) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5185) 5185 FORMAT('      ', 1 'Note: Schiller-Eberhardt Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5186) 5186 FORMAT('      ', 1 '         ', 1 '5 or Fewer Labs') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5191) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5193) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 8002 FORMAT(A1,'begin{table}') 8005 FORMAT(A1,'begin{center}') 8006 FORMAT(5X,A1,'begin{tabular} {lr}') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8002)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8005)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8006)IBASLC CALL DPWRST('XXX','WRIT') C 8011 FORMAT(5X,'{',A1,'bf 5. Method: Schiller-Eberhardt:} & ', 1 2X,A1,A1) 8012 FORMAT(5X,'Estimate of Consensus Mean: & ', 1 F15.7,2X,A1,A1) 8013 FORMAT(5X,'Estimate of Variance of Mean: & ', 1 F15.7,2X,A1,A1) 8014 FORMAT(5X,'Bias Allowance: & ', 1 F15.7,2X,A1,A1) 8015 FORMAT(5X,'Sigmah (heterogeneity): & ', 1 F15.7,2X,A1,A1) 8016 FORMAT(5X,'Degrees of Freedom for Sigmah: & ', 1 I8,2X,A1,A1) C WRITE(ICOUT,8011)IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8012)XSE,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8013)XSES2,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8014)ABIAS,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8015)SIGMAH,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8016)IDFH,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8020 FORMAT(5X,'Standard Uncertainty (k = 1): & ', 1 F15.7,2X,A1,A1) 8021 FORMAT(5X,'Expanded Uncertainty (k = 2): & ', 1 F15.7,2X,A1,A1) 8022 FORMAT(5X,'Expanded Uncertainty (k = ',F10.7,'): & ', 1 F15.7,2X,A1,A1) WRITE(ICOUT,8020)DSESU1,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8021)DSESU2,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8022)APPF,DSEU,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8024 FORMAT(5X,'Degrees of Freedom: & ', 1 I8,2X,A1,A1) 8025 FORMAT(5X,'t Percent Point Value of 0.975: & ', 1 F15.7,2X,A1,A1) 8026 FORMAT(5X,'Lower 95',A1,'% Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8027 FORMAT(5X,'Upper 95',A1,'% Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8028 FORMAT(5X,'Note: Schiller-Eberhardt Best Usage: & ', 1 2X,A1,A1) 8029 FORMAT(5X,' 5 or Fewer Labs & ', 1 2X,A1,A1) WRITE(ICOUT,8024)IDF,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8025)APPF,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8026)IBASLC,DLOWSE,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IBASLC,DHIGSE,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8028)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8029)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8030 FORMAT(A1,'end{tabular}') 8031 FORMAT(A1,'end{center}') 8032 FORMAT(A1,'end{table}') WRITE(ICOUT,8030)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8031)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8032)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN C CALL DPCONA(92,IBASLC) C 6191 FORMAT(A1,'f',I1) IF(IRTFFF.EQ.'Courier New')THEN ITEMP=1 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN ITEMP=8 ELSE ITEMP=1 ENDIF WRITE(ICOUT,6191)IBASLC,ITEMP CALL DPWRST(ICOUT,'WRIT') C NCOL=4 IDEFPS=20 IFRST=IRTFPS*5500/IDEFPS IINC1=IRTFPS*1540/IDEFPS C DO6105ISET1=1,NCOL VALIGN(ISET1)='b' ALIGN(ISET1)='r' IF(NUMDI2(ISET1).LT.0.OR.NUMDI2(ISET1).GT.9)NUMDI2(ISET1)=7 6105 CONTINUE ALIGN(1)='l' NUMDI2(1)=0 NUMDI2(2)=7 C IWIDTH(1)=IFRST IWIDTH(2)=IWIDTH(1) + IINC1 C ITTEMP=' ' NCTEMP=0 NHEAD=0 C CALL DPRTF1(ITTEMP,NCTEMP,IHEAD,NHEAD) C NHEAD=2 IFLAG1=.FALSE. IFLAG2=.FALSE. C IVALUE(1)=' b 5. Method: Schiller-Eberhardt' IVALUE(1)(1:1)=IBASLC NCHAR(1)=32 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IFLAG1=.FALSE. NHEAD=1 C NCHAR(1)=32 IVALUE(1)=' Estimate of Consensus Mean:' AVALUE(2)=XSE CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Estimate of Variance of Mean:' AVALUE(2)=XSES2 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=18 IVALUE(1)=' Bias Allowance:' AVALUE(2)=ABIAS CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=26 IVALUE(1)=' Sigmah (heterogeneity):' AVALUE(2)=SIGMAH CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=33 IVALUE(1)=' Degrees of Freedom for Sigmah:' AVALUE(2)=IDFH NJUNK=NUMDI2(2) NUMDI2(2)=0 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) NUMDI2(2)=NJUNK C NCHAR(1)=32 IVALUE(1)=' Standard Uncertainty (k = 1):' AVALUE(2)=DSESU1 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Expanded Uncertainty (k = 2):' AVALUE(2)=DSESU2 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=41 IVALUE(1)(1:29)=' Expanded Uncertainty (k = ' WRITE(IVALUE(1)(30:39),'(F10.7)')APPF IVALUE(1)(40:41)='):' AVALUE(2)=DSEU CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=34 IVALUE(1)=' t Percent Point Value of 0.975:' AVALUE(2)=APPF CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=22 IVALUE(1)=' Degrees of Freedom:' AVALUE(2)=IDF NJUNK=NUMDI2(2) NUMDI2(2)=0 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) NUMDI2(2)=NJUNK C NCHAR(1)=39 IVALUE(1)=' Lower 95% (normal) Confidence Limit:' AVALUE(2)=REAL(DLOWSE) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=39 IVALUE(1)=' Upper 95% (normal) Confidence Limit:' AVALUE(2)=REAL(DHIGSE) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C IVALUE(1)=' Note: Schiller-Eberhardt Best Usage:' NCHAR(1)=39 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IVALUE(1)=' 5 or Fewer Labs:' NCHAR(1)=25 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C CALL DPRTF6(NHEAD) IFLAG1=.TRUE. IFLAG2=.FALSE. C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'WOML')THEN ELSE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4001) 4001 FORMAT('5. Method: Schiller-Eberhardt') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4002)XSE 4002 FORMAT(' Estimate of Consensus Mean: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4003)XSES2 4003 FORMAT(' Estimate of Variance of Mean: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4004)ABIAS 4004 FORMAT(' Bias Allowance: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4005)SIGMAH 4005 FORMAT(' Sigmah (heterogeneity): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4006)IDFH 4006 FORMAT(' Degrees of Freedom for Sigmah: ', 1 I8) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4012)DSESU1 4012 FORMAT(' Standard Uncertainty (k = 1): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4013)DSESU2 4013 FORMAT(' Expanded Uncertainty (k = 2): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4014)APPF,DSEU 4014 FORMAT(' Expanded Uncertainty (k = ',F10.7,'): ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4020)IDF 4020 FORMAT(' Degrees of Freedom: ', 1 I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4021)APPF 4021 FORMAT(' t Percent Point Value (alpha = 0.05): ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4022)REAL(DLOWSE) 4022 FORMAT(' Lower 95% Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4023)REAL(DHIGSE) 4023 FORMAT(' Upper 95% Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4031) 4031 FORMAT(' Note: Schiller-Eberhardt Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4032) 4032 FORMAT(' 5 or Fewer Labs') CALL DPWRST('XXX','WRIT') C ENDIF ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SCEB')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSCEB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPTS,NLAB 9013 FORMAT('NPTS,NLAB = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)XSE,XSES2,DSEU 9014 FORMAT('XSE,XSES2,DSEU = ',3G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DLOWSE,DHIGSE 9015 FORMAT('DLOWSE,DHIGSE = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPSCI2(X1,Y1,X2,Y2, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--DRAW A SEMI-CIRCLE C WITH ONE END OF THE DIAGONAL AT (X1,Y1) C AND THE OTHER END AT (X2,Y2). C NOTE--THE SEMI-CIRCLE WILL BE DRAWN CLOCKWISE. 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 --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) C C-----NON-COMMON VARIABLES------------------------------------- C CHARACTER*4 IFIG CHARACTER*4 IPATT2 C CHARACTER*4 ILINPA CHARACTER*4 ILINCO C CHARACTER*4 IREBLI CHARACTER*4 IREBCO CHARACTER*4 IREFSW CHARACTER*4 IREFCO CHARACTER*4 IREPTY CHARACTER*4 IREPLI CHARACTER*4 IREPCO C CHARACTER*4 IPATT CHARACTER*4 ICOLF CHARACTER*4 ICOLP CHARACTER*4 ICOL CHARACTER*4 IFLAG C DIMENSION PX(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.'SCI2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSCI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)X1,Y1 53 FORMAT('X1,Y1 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)X2,Y2 54 FORMAT('X2,Y2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IFIG 59 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)AREGBA(1) 62 FORMAT('AREGBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 1A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)PTEXHE,PTEXWI 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70)PTEXVG,PTEXHG 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************* C ** STEP 1-- ** C ** DETERMINE THE COORDINATES ** C ** FOR THE SEMI-CIRCLE ** C ********************************* C DELX=X2-X1 DELY=Y2-Y1 ALEN=0.0 TERM=(X2-X1)**2+(Y2-Y1)**2 IF(TERM.GT.0.0)ALEN=SQRT(TERM) RADIUS=ALEN/2.0 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+X2)/2.0 YCENT=(Y1+Y2)/2.0 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=1,181,5 IREV=181-I+1 PHI2=IREV-1 PHI2=PHI2*(2.0*3.1415926)/360.0 X=RADIUS*COS(PHI2)+RADIUS Y=RADIUS*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 CLE ** 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.'SCI2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSCI2--') 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 DPSCIR(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 SEMI-CIRCLES C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE SEMI-CIRCLE WILL BE DRAWN CLOCKWISE. C NOTE--THE INPUT COORDINATES DEFINE THE ENDS OF THE DIAMETER C OF THE SEMI-CIRCLE. C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2 C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4. C NOTE--IF 2 NUMBERS ARE PROVIDED, C THEN THE DRAWN SEMI-CIRCLE WILL GO C FROM THE LAST CURSOR POSITION C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE 2 NUMBERS. C NOTE--IF 4 NUMBERS ARE PROVIDED, C THEN THE DRAWN SEMI-CIRCLE WILL GO C FROM THE ABSOLUTE (X,Y) POSITION C AS DEFINED BY THE FIRST 2 NUMBERS C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE THIRD AND FOURTH NUMBERS. C NOTE--IF 6 NUMBERS ARE PROVIDED, C THEN THE DRAWN SEMI-CIRCLE WILL GO C FROM THE (X,Y) POSITION C AS RESULTING FROM THE THIRD AND FOURTH NUMBERS C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE FIFTH AND SIXTH NUMBERS. C NOTE--AND SO FORTH FOR 8, 10, 12, ... 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.'SCIR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSCIR--') 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='SCIR' NUMPT=2 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.3.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ABSO'.AND. 1IARGT(3).EQ.'NUMB'.AND.IARGT(4).EQ.'NUMB') 1GOTO1113 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'RELA'.AND. 1IARGT(3).EQ.'NUMB'.AND.IARGT(4).EQ.'NUMB') 1GOTO1114 GOTO1130 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='ABSO' ILOCFN=3 GOTO1119 C 1114 CONTINUE ITYPEO='RELA' ILOCFN=3 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 DPSCIR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR SEMI-CIRCLE ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A SEMI-CIRCLE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH ONE END OF A DIAGONAL AT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' AND THE OTHER END OF THE DIAGONAL AT 40 60,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' SEMI-CIRCLE 20 20 40 60') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' SEMI-CIRCLE ABSOLUTE 20 20 40 60') 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 C 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 CALL DPSCI2(X1,Y1,X2,Y2, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C X1=X2 Y1=Y2 C GOTO1160 1190 CONTINUE C PXEND=X2 PYEND=Y2 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.'SCIR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSCIR--') 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 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.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 DPSCR7(ISTRIN,NUMCHA,X0,Y0, 1IFONT,ICASE,IJUST,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANUMHP,ANUMVP, 1IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL, 1ISYMBL,ISPAC, 1IFILL, 1IMPSW2,AMPSCH,AMPSCW, 1XEND,YEND,IFOUND,IBUGD2,IERROR) 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 1981. C UPDATED --OCTOBER 1981. C UPDATED --MAY 1982. C UPDATED --OCTOBER 1993. HANDLE LOWER CASE CHARACTERS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISTRIN C CHARACTER*4 IPATT CHARACTER*4 IFONT CHARACTER*4 ICASE CHARACTER*4 IJUST CHARACTER*4 ICOL C CHARACTER*4 ISYMBL CHARACTER*4 ISPAC CHARACTER*4 IFILL C CHARACTER*4 IFOUND CHARACTER*4 IBUGD2 CHARACTER*4 IERROR C CHARACTER*4 ISEQUE CHARACTER*4 ISUBSU CHARACTER*4 IDRAW CHARACTER*4 IFOUNO CHARACTER*4 IFONSV CHARACTER*4 ICASSV CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IFOUNC CCCCC OCTOBER 1993. ADD FOLLOWING LINE CHARACTER*4 ICASE2 C C--------------------------------------------------------------------- C DIMENSION ISTRIN(*) C C-----COMMON---------------------------------------------------------- C C CHARACTER*4 IMPSW2 C 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 CCCCC OCTOBER 1993. ADD FOLLOWING LINE ICASE2='UPPE' ISEQUE='ON' ISUBSU='OFF' C C X02=50.0 Y02=50.0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR7')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSCR7--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)X0,Y0,IFONT,ICASE,IJUST,ANGLE 52 FORMAT('X0,Y0,IFONT,ICASE,IJUST,ANGLE = ', 1E15.7,E15.7,2X,A4,2X,A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)HMAX,VMAX,AMAX,WIDTH,HEIGHT 53 FORMAT('HMAX,VMAX,AMAX,WIDTH,HEIGHT = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ANUMHP,ANUMVP 54 FORMAT('ANUMHP,ANUMVP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)XEND,YEND,IBUGD2 55 FORMAT('XEND,YEND,IBUGD2 = ',E15.7,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMCHA 56 FORMAT('NUMCHA = ',I8) CALL DPWRST('XXX','BUG ') DO57I=1,NUMCHA WRITE(ICOUT,58)I,ISTRIN(I) 58 FORMAT('I,ISTRIN(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 57 CONTINUE WRITE(ICOUT,59)IBUGG4,ISUBG4 59 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)ICOL,JCOL,PTHICK,JTHICK,PTHIC2 60 FORMAT('ICOL,JCOL,PTHICK,JTHICK,PTHIC2 = ', 1A4,I8,E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)IPATT,JPATT 61 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)PHEIGH,PWIDTH,PVEGAP,PHOGAP 62 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)PHEIG2,PWIDT2,PVEGA2,PHOGA2 63 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)ISYMBL,ISPAC 65 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)IFILL 66 FORMAT('IFILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)IFOUND,IBUGD2,IERROR 68 FORMAT('IFOUND,IBUGD2,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4 69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************* C ** STEP XX-- ** C ** SAVE INPUT VALUES ** C ************************* C IFONSV=IFONT ICASSV=ICASE HEIGSV=HEIGHT WIDTSV=WIDTH C PHEISV=PHEIGH PWIDSV=PWIDTH PVEGSV=PVEGAP PHOGSV=PHOGAP C PHE2SV=PHEIG2 PWI2SV=PWIDT2 PVG2SV=PVEGA2 PHG2SV=PHOGA2 C IF(IMPSW2.EQ.'ON')THEN PHEIGH=PHEIGH*AMPSCH PVEGAP=PVEGAP*AMPSCH PWIDTH=PWIDTH*AMPSCW PHOGAP=PHOGAP*AMPSCW PHEIG2=PHEIG2*AMPSCH PVEGA2=PVEGA2*AMPSCH PWIDT2=PWIDT2*AMPSCW PHOGA2=PHOGA2*AMPSCW HEIGHT=HEIGHT*AMPSCH WIDTH=WIDTH*AMPSCW ENDIF C C ********************************************* C ** STEP XX-- ** C ** DETERMINE THE LOCATION ** C ** OF THE RIGHT-MOST NON-BLANK CHARACTER ** C ********************************************* C DO300I=1,NUMCHA IREV=NUMCHA-I+1 IF(ISTRIN(IREV).NE.' ')GOTO305 300 CONTINUE NUMCHS=0 GOTO309 305 CONTINUE NUMCHS=IREV 309 CONTINUE C C ************************************* C ** STEP XX-- ** C ** DETERMINE THE LOCATION ** C ** OF THE RIGHT-MOST PARENTHESIS ** C ************************************* C ILOCR2=0 DO600I=1,NUMCHS IREV=NUMCHS-I+1 IF(ISTRIN(IREV).EQ.')')GOTO610 600 CONTINUE GOTO690 610 CONTINUE ILOCR2=IREV GOTO690 690 CONTINUE C C *********************************************** C ** STEP XX-- ** C ** PROCEED SEQUENTIALLY THROUGH THE STRING ** C *********************************************** C IF(IJUST.EQ.'LEFT')GOTO1100 IF(IJUST.EQ.'LEBO')GOTO1100 IF(IJUST.EQ.'LECE')GOTO1100 IF(IJUST.EQ.'LETO')GOTO1100 C IF(IJUST.EQ.'CENT')GOTO1200 IF(IJUST.EQ.'CEBO')GOTO1200 IF(IJUST.EQ.'CECE')GOTO1200 IF(IJUST.EQ.'CETO')GOTO1200 C IF(IJUST.EQ.'RIGH')GOTO1200 IF(IJUST.EQ.'RIBO')GOTO1200 IF(IJUST.EQ.'RICE')GOTO1200 IF(IJUST.EQ.'RITO')GOTO1200 C GOTO1100 C C ***************************************** C ** STEP 11-- ** C ** TREAT THE LEFT-JUSTIFICATION CASE ** C ***************************************** C 1100 CONTINUE C IEND=0 C XEND=X0 YEND=Y0 IF(IJUST.EQ.'LECE')YEND=Y0-PHEIGH/2.0 IF(IJUST.EQ.'LETO')YEND=Y0-PHEIGH C 1110 CONTINUE ISTART=IEND+1 IF(ISTART.GT.NUMCHS)GOTO1190 C C ************************************ C ** STEP 12-- ** C ** DECODE THE NEXT CHARACTER ** C ** (OR THE NEXT FEW CHARACTERS) ** C ************************************ C CALL DPSCAN(ISTART,ISTRIN,NUMCHS,ILOCR2, 1ICHAR2,IOP,IFONT,ICASE,IJUST,ISEQUE,ISUBSU, 1HMAX,VMAX,AMAX,X0,Y0,ANGLE,WIDTH,HEIGHT, 1IEND,IFOUNC,IFOUNO,IBUGD2,IERROR) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 1WRITE(ICOUT,1112)ICHAR2,IOP,ISTART,IEND,IFOUNC, 1IFOUNO 1112 FORMAT('ICHAR2,IOP,ISTART,IEND,IFOUNC,IFOUNO = ', 1A4,2X,A4,I8,I8,2X,A4,2X,A4) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 1CALL DPWRST('XXX','BUG ') C C ****************************** C ** STEP 13-- ** C ** DRAW OUT THE CHARACTER ** C ****************************** C CALL DPSBSP(IFOUNO,IOP,XEND,YEND,HEIGHT,WIDTH, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANGLE,AMAX, 1IBUGD2,IERROR) IF(IFOUNO.EQ.'YES')GOTO1180 C XSTART=XEND YSTART=YEND C IDRAW='ON' CCCCC OCTOBER 1993. HANDLE CASE IF ICHAR2 IS LOWER CASE. ICASE2=ICASE CALL DPCOAN(ICHAR2(1:1),IVAL) IF(IVAL.GE.97.AND.IVAL.LE.122)THEN IVAL=IVAL-32 CALL DPCONA(IVAL,ICHAR2(1:1)) IF(ICASE.EQ.'LOWE'.OR.ICASE.EQ.'ASIS')ICASE2='LOWE' ELSE IF(ICASE.EQ.'ASIS')ICASE2='UPPE' END IF CCCCC END CHANGE C CALL DPSCR8(ICHAR2,XSTART,YSTART,IDRAW, CCCCC1IFONT,ICASE,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 1IFONT,ICASE2,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANUMHP,ANUMVP, 1IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL, 1XEND,YEND, 1ISPAC, 1IFILL, 1IFOUND,IBUGD2,IERROR) C 1180 CONTINUE GOTO1110 C 1190 CONTINUE IF(IJUST.EQ.'LECE')YEND=YEND+PHEIGH/2.0 IF(IJUST.EQ.'LETO')YEND=YEND+PHEIGH GOTO8000 C C ***************************************** C ** STEP 21-- ** C ** TREAT THE CENTER-JUSTIFICATION ** C ** AND THE RIGHT-JUSTIFICATION CASES ** C ***************************************** C 1200 CONTINUE C XLEN=0.0 YLEN=0.0 C IEND=0 C IDRAW='OFF' C XEND99=X0 YEND99=Y0 C 1210 CONTINUE ISTART=IEND+1 IF(ISTART.GT.NUMCHS)GOTO1250 C C ************************************ C ** STEP 22-- ** C ** DECODE THE NEXT CHARACTER ** C ** (OR THE NEXT FEW CHARACTERS) ** C ************************************ C CALL DPSCAN(ISTART,ISTRIN,NUMCHS,ILOCR2, 1ICHAR2,IOP,IFONT,ICASE,IJUST,ISEQUE,ISUBSU, 1HMAX,VMAX,AMAX,X0,Y0,ANGLE,WIDTH,HEIGHT, 1IEND,IFOUNC,IFOUNO,IBUGD2,IERROR) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 1WRITE(ICOUT,1212)ICHAR2,IOP,ISTART,IEND,IFOUNC, 1IFOUNO 1212 FORMAT('ICHAR2,IOP,ISTART,IEND,IFOUNC,IFOUNO = ', 1A4,2X,A4,I8,I8,2X,A4,2X,A4) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 1CALL DPWRST('XXX','BUG ') C C ********************************************* C ** STEP 23-- ** C ** DETERMINE THE LENGTH OF THE CHARACTER ** C ********************************************* C CALL DPSBSP(IFOUNO,IOP,XEND99,YEND99,HEIGHT,WIDTH, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANGLE,AMAX, 1IBUGD2,IERROR) IF(IFOUNO.EQ.'YES')GOTO1240 C XSTA99=XEND99 YSTA99=YEND99 CCCCC OCTOBER 1993. HANDLE CASE IF ICHAR2 IS LOWER CASE. ICASE2=ICASE CALL DPCOAN(ICHAR2(1:1),IVAL) IF(IVAL.GE.97.AND.IVAL.LE.122)THEN IVAL=IVAL-32 CALL DPCONA(IVAL,ICHAR2(1:1)) IF(ICASE.EQ.'LOWE'.OR.ICASE.EQ.'ASIS')ICASE2='LOWE' ELSE IF(ICASE.EQ.'ASIS')ICASE2='UPPE' END IF CCCCC END CHANGE C CALL DPSCR8(ICHAR2,XSTA99,YSTA99,IDRAW, CCCCC1IFONT,ICASE,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 1IFONT,ICASE2,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANUMHP,ANUMVP, 1IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL, 1XEND99,YEND99, 1ISPAC, 1IFILL, 1IFOUND,IBUGD2,IERROR) C 1240 CONTINUE GOTO1210 C 1250 CONTINUE XLEN=XEND99-X0 YLEN=YEND99-Y0 C C *************************************** C ** STEP 24-- ** C ** RESTORE VALUES TO THOSE AT TIME ** C ** OF INPUT TO THIS SUBROUTINE ** C *************************************** C IFONT=IFONSV ICASE=ICASSV HEIGHT=HEIGSV WIDTH=WIDTSV C PHEIGH=PHEISV PWIDTH=PWIDSV PVEGAP=PVEGSV PHOGAP=PHOGSV C PHEIG2=PHE2SV PWIDT2=PWI2SV PVEGA2=PVG2SV PHOGA2=PHG2SV C IF(IMPSW2.EQ.'ON')THEN PHEIGH=PHEIGH*AMPSCH PVEGAP=PVEGAP*AMPSCH PWIDTH=PWIDTH*AMPSCW PHOGAP=PHOGAP*AMPSCW PHEIG2=PHEIG2*AMPSCH PVEGA2=PVEGA2*AMPSCH PWIDT2=PWIDT2*AMPSCW PHOGA2=PHOGA2*AMPSCW HEIGHT=HEIGHT*AMPSCH WIDTH=WIDTH*AMPSCW ENDIF C ************************************************ C ** STEP 25-- ** C ** COMPUTE STARTING POINT ** C ** FOR THE CENTER- OR RIGHT-JUSTIFIED STRING ** C ************************************************ C CCCCC IF(IJUST.EQ.'CENT')X02=X0-(XLEN/2.0) IF(IJUST.EQ.'CENT')X02=X0-(XLEN/2.0)+(PHOGAP/2.0) IF(IJUST.EQ.'CENT')Y02=Y0-(YLEN/2.0) C CCCCC IF(IJUST.EQ.'CEBO')X02=X0-(XLEN/2.0) IF(IJUST.EQ.'CEBO')X02=X0-(XLEN/2.0)+(PHOGAP/2.0) IF(IJUST.EQ.'CEBO')Y02=Y0-(YLEN/2.0) C CCCCC IF(IJUST.EQ.'CECE')X02=X0-(XLEN/2.0) IF(IJUST.EQ.'CECE')X02=X0-(XLEN/2.0)+(PHOGAP/2.0) IF(IJUST.EQ.'CECE')Y02=Y0-(YLEN/2.0)-PHEIGH/2.0 C CCCCC IF(IJUST.EQ.'CETO')X02=X0-(XLEN/2.0) IF(IJUST.EQ.'CETO')X02=X0-(XLEN/2.0)+(PHOGAP/2.0) IF(IJUST.EQ.'CETO')Y02=Y0-(YLEN/2.0)-PHEIGH C IF(IJUST.EQ.'RIGH')X02=X0-XLEN IF(IJUST.EQ.'RIGH')Y02=Y0-YLEN C IF(IJUST.EQ.'RIBO')X02=X0-XLEN IF(IJUST.EQ.'RIBO')Y02=Y0-YLEN C IF(IJUST.EQ.'RICE')X02=X0-XLEN IF(IJUST.EQ.'RICE')Y02=Y0-YLEN-PHEIGH/2.0 C IF(IJUST.EQ.'RITO')X02=X0-XLEN IF(IJUST.EQ.'RITO')Y02=Y0-YLEN-PHEIGH C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR7')GOTO1259 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1251) 1251 FORMAT('***** FROM THE MIDDLE OF DPSCR7--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1252)IJUST,XLEN,YLEN,PWIDT2,PHEIG2 1252 FORMAT('IJUST,XLEN,YLEN,PWIDT2,PHEIG2 = ',A4,4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1253)X0,Y0,X02,Y02 1253 FORMAT('X0,Y0,X02,Y02 = ',4E15.7) CALL DPWRST('XXX','BUG ') 1259 CONTINUE C IEND=0 C XEND=X02 YEND=Y02 C IDRAW='ON' C 1260 CONTINUE ISTART=IEND+1 IF(ISTART.GT.NUMCHS)GOTO1290 C C ************************************ C ** STEP 26-- ** C ** DECODE THE NEXT CHARACTER ** C ** (OR THE NEXT FEW CHARACTERS) ** C ************************************ C CALL DPSCAN(ISTART,ISTRIN,NUMCHS,ILOCR2, 1ICHAR2,IOP,IFONT,ICASE,IJUST,ISEQUE,ISUBSU, 1HMAX,VMAX,AMAX,X0,Y0,ANGLE,WIDTH,HEIGHT, 1IEND,IFOUNC,IFOUNO,IBUGD2,IERROR) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 1WRITE(ICOUT,1262)ICHAR2,IOP,ISTART,IEND,IFOUNC, 1IFOUNO 1262 FORMAT('ICHAR2,IOP,ISTART,IEND,IFOUNC,IFOUNO = ', 1A4,2X,A4,I8,I8,2X,A4,2X,A4) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 1CALL DPWRST('XXX','BUG ') C C ****************************** C ** STEP 27-- ** C ** DRAW OUT THE CHARACTER ** C ****************************** C CALL DPSBSP(IFOUNO,IOP,XEND,YEND,HEIGHT,WIDTH, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANGLE,AMAX, 1IBUGD2,IERROR) IF(IFOUNO.EQ.'YES')GOTO1280 C XSTART=XEND YSTART=YEND CCCCC OCTOBER 1993. HANDLE CASE IF ICHAR2 IS LOWER CASE. ICASE2=ICASE CALL DPCOAN(ICHAR2(1:1),IVAL) IF(IVAL.GE.97.AND.IVAL.LE.122)THEN IVAL=IVAL-32 CALL DPCONA(IVAL,ICHAR2(1:1)) IF(ICASE.EQ.'LOWE'.OR.ICASE.EQ.'ASIS')ICASE2='LOWE' ELSE IF(ICASE.EQ.'ASIS')ICASE2='UPPE' END IF CCCCC END CHANGE C CALL DPSCR8(ICHAR2,XSTART,YSTART,IDRAW, CCCCC1IFONT,ICASE,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 1IFONT,ICASE2,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANUMHP,ANUMVP, 1IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL, 1XEND,YEND, 1ISPAC, 1IFILL, 1IFOUND,IBUGD2,IERROR) C 1280 CONTINUE GOTO1260 C 1290 CONTINUE IF(IJUST.EQ.'CECE')YEND=YEND+PHEIGH/2.0 IF(IJUST.EQ.'CETO')YEND=YEND+PHEIGH IF(IJUST.EQ.'RICE')YEND=YEND+PHEIGH/2.0 IF(IJUST.EQ.'RITO')YEND=YEND+PHEIGH GOTO8000 C C *************************************** C ** STEP 28-- ** C ** RESTORE VALUES TO THOSE AT TIME ** C ** OF INPUT TO THIS SUBROUTINE ** C *************************************** C 8000 CONTINUE IFONT=IFONSV ICASE=ICASSV WIDTH=WIDTSV HEIGHT=HEIGSV C PHEIGH=PHEISV PWIDTH=PWIDSV PVEGAP=PVEGSV PHOGAP=PHOGSV C PHEIG2=PHE2SV PWIDT2=PWI2SV PVEGA2=PVG2SV PHOGA2=PHG2SV GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR7')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSCR7--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)XEND,YEND 9012 FORMAT('XEND,YEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IPATT,JPATT 9013 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)ICOL,JCOL,PTHICK,JTHICK,PTHIC2 9020 FORMAT('ICOL,JCOL,PTHICK,JTHICK,PTHIC2 = ', 1A4,I8,E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)PHEIGH,PWIDTH,PVEGAP,PHOGAP 9022 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)PHEIG2,PWIDT2,PVEGA2,PHOGA2 9023 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)ISYMBL,ISPAC 9025 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)IFILL 9026 FORMAT('IFILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IFOUND,IBUGD2,IERROR 9028 FORMAT('IFOUND,IBUGD2,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSCR8(ICHAR2,XSTART,YSTART,IDRAW, 1IFONT,ICASE,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANUMHP,ANUMVP, 1IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL, 1XEND,YEND, 1ISPAC, 1IFILL, 1IFOUND,IBUG,IERROR) C C PURPOSE--SCRIBE OUT THE SINGLE CHARACTER C IN THE HOLLERITH VARIABLE ICHAR2. C NOTE--ICHAR2 SHOULD CONTAIN A SINGLE CHARACTER C OR SHOULD CONTAIN AN ABBREVIATED C STRING (4 CHARACTERS AT MOST) INDICATING A DESIRED C MATH OPERATION, GREEK LETTER, ETC. C THE ABBREVIATED STRING HAS HAD () REMOVED. C THE PRE-CHECKING AND FORMATION OF A VALID ICHAR2 C WAS DONE IN DPSCAN. C INPUT ARGUMENTS--ICHAR2 = THE HOLLERITH VARIABLE C CONTAINING THE CHARACTER OF INTEREST. C XSTART = THE STARTING HORIZONTAL COORDINATE; C THE HORIZONTAL COORDINATE OF THE C BOTTOM LEFT POINT OF THE FIRST CHARACTER. C XSTART MAY BE IN ANY UNITS, BUT IS USUALLY C GIVEN IN % UNITS, INCHES, CENTIMETERS, OR C TEKTRONIX PICTURE POINTS. C YSTART = THE STARTING VERTICAL COORDINATE; C THE VERTICAL COORDINATE OF THE C BOTTOM LEFT POINT OF THE FIRST CHARACTER. C YSTART MAY BE IN ANY UNITS, BUT IS USUALLY C GIVEN IN % UNITS, INCHES, CENTIMETERS, OR C TEKTRONIX PICTURE POINTS. C HEIGHT = THE HEIGHT OF THE CHARACTERS (INCLUDING GAP); C THE HEIGHT OF A CHARACTER C MAY BE IN ANY UNITS, BUT IS USUALLY C GIVEN IN % UNITS, INCHES, CENTIMETERS, OR C TEKTRONIX PICTURE POINTS. C C WIDTH = THE WIDTH OF THE CHARACTERS (INCLUDING GAP); C THE WIDTH OF A CHARACTER C MAY BE IN ANY UNITS, BUT IS USUALLY C GIVEN IN % UNITS, INCHES, CENTIMETERS, OR C TEKTRONIX PICTURE POINTS. 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-- C UPDATED --SEPTEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --OCTOBER 1991. ADDED SOME ABBREVIATIONS FOR CHARACTER C FILL. ALAN C UPDATED --AUGUST 1992. ADD SOME CHAR FILL (ALAN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IDRAW CHARACTER*4 IPATT CHARACTER*4 IFONT CHARACTER*4 ICASE CHARACTER*4 ICOL CHARACTER*4 ISPAC CHARACTER*4 IFILL C CHARACTER*4 IFOUND CHARACTER*4 IBUG CHARACTER*4 IERROR C CHARACTER*4 IOP CHARACTER*4 IFIG CHARACTER*4 IMATH CHARACTER*4 ICHAR3 CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA C CHARACTER*4 ICOLF CHARACTER*4 ICOLP CHARACTER*4 IFLAG C CHARACTER*4 IPATT2 C C--------------------------------------------------------------------- C DIMENSION IOP(100) DIMENSION X(100) DIMENSION Y(100) C DIMENSION PX(100) DIMENSION PY(100) C CCCCC DIMENSION PX3(100) CCCCC DIMENSION PY3(100) C C-----COMMON---------------------------------------------------------- C 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 IPATT2='SOLI' C IMATH='NO' C XFACHP=1.0 YFACHP=1.0 C XMINC=0.0 XMAXC=0.0 XMINC2=0.0 XMAXC2=0.0 YMINC2=0.0 YMAXC2=0.0 C X2=0.0 X3=0.0 X4=0.0 C XEND2=(-999.0) YEND2=(-999.0) C I2=(-999) C PPENTH=(-999.0) NLOOP=(-999) C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR8')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('****** AT THE BEGINNING OF DPSCR8--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2,XSTART,YSTART,IDRAW,WIDTH,HEIGHT 52 FORMAT('ICHAR2,XSTART,YSTART,IDRAW,WIDTH,HEIGHT = ', 1A4,2E15.7,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IFONT,ICASE,ANGLE 53 FORMAT('IFONT,ICASE,ANGLE = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)HMAX,VMAX,AMAX 54 FORMAT('HMAX,VMAX,AMAX = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)ANUMHP,ANUMVP 55 FORMAT('ANUMHP,ANUMVP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)ISPAC 56 FORMAT('ISPAC = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IFILL 57 FORMAT('IFILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)XEND,YEND 58 FORMAT('XEND,YEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IPATT,JPATT 59 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)ICOL,JCOL,PTHICK,JTHICK,PTHIC2 60 FORMAT('ICOL,JCOL,PTHICK,JTHICK,PTHIC2 = ', 1A4,I8,E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)PHEIGH,PWIDTH,PVEGAP,PHOGAP 62 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)PHEIG2,PWIDT2,PVEGA2,PHOGA2 63 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)IFOUND,IBUGG4,ISUBG4,IERROR 69 FORMAT('IFOUND,IBUGG4,ISUBG4,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C CCCCC ****************************************************** CCCCC ** STEP 3.0-- ** CCCCC ** COPY OVER VALUES FOR THE USUAL CASE (= 1 PASS) ** CCCCC ****************************************************** CCCCC CCCCC ISTART = LOCATION (1 TO 4) OF FIRST CHARACTER IN ICHAR2 CCCCC (IF FIRST CHARACTER IS BLANK, THEN ISTART STILL = 1) CCCCC ISTOP = LOCATION (1 TO 4) OF LAST NON-BLANK CHARACTER IN ICHAR2 CCCCC OR OF LAST CHARACTER BEFORE ( CCCCC (UNLESS ( IS IN LOCATION 1) CCCCC IPOINT = LOCATION (1 TO 4) OF CURRENTLOCATION OF ITNTEREST. CCCCC ICHAR3 EITHER HAS ELEMENTS IPOINT TO ISTOP OF ICHAR2 CCCCC OR (IF NO MATCH WAS FOUND), CCCCC ELEMENTS IPOINT OT IPOINT OF ICHAR2. CCCCC ISTART AND ISTOP DO NOT CHANGE. CCCCC IPOINT MAY CHANGE (INCREASE) IF NO MATCH CCCCC CCCCC ISTART=1 CCCCC ISTOP=4 CCCCC ICTEMP=ICHAR2(4:4) CCCCC IF(ICTEMP.EQ.' ')ISTOP=3 CCCCC IF(ICTEMP.EQ.'(')ISTOP=3 CCCCC ICTEMP=ICHAR2(3:3) CCCCC IF(ICTEMP.EQ.' ')ISTOP=2 CCCCC IF(ICTEMP.EQ.'(')ISTOP=2 CCCCC ICTEMP=ICHAR2(2:2) CCCCC IF(ICTEMP.EQ.' ')ISTOP=1 CCCCC IF(ICTEMP.EQ.'(')ISTOP=1 CCCCC CCCCC IPOINT=ISTART C ICHAR3=ICHAR2 XSTAR2=XSTART YSTAR2=YSTART C C ********************************************** C ** STEP 3.1-- ** C ** TREAT THE ROMAN ALPHABET, NUMERIC, AND ** C ** STANDARD SYMBOLS CASE ** C ********************************************** C 1200 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR8')GOTO1209 WRITE(ICOUT,1201) 1201 FORMAT('***** FROM NEAR BEGINNING OF DPSCR8--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1202)ICHAR2,ICHAR3 1202 FORMAT('ICHAR2,ICHAR3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1203)I2,ISTART,ISTOP C1203 FORMAT('I2,ISTART,ISTOP = ',3I8) CCCCC CALL DPWRST('XXX','BUG ') 1209 CONTINUE C IF(IFONT.EQ.'SIMP')GOTO1210 IF(IFONT.EQ.'DUPL')GOTO1220 IF(IFONT.EQ.'TRIP')GOTO1230 IF(IFONT.EQ.'COMP')GOTO1240 IF(IFONT.EQ.'TRII')GOTO1250 IF(IFONT.EQ.'COMI')GOTO1260 IF(IFONT.EQ.'SIMS')GOTO1270 IF(IFONT.EQ.'COMS')GOTO1280 GOTO1240 C 1210 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPRSU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPRSL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRSN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRSS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1290 GOTO1900 C 1220 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPRDU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPRDL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRDN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRDS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1290 GOTO1900 C 1230 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPRTU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPRTL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRTN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRTS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1290 GOTO1900 C 1240 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPRCU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPRCL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRCN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRCS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1290 GOTO1900 C 1250 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPRTIU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPRTIL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRTIN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) CCCCC IF(IFOUND.EQ.'NO') CCCCC1CALL DPRTIS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, CCCCC1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRTS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1290 GOTO1900 C 1260 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPRCIU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPRCIL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRCIN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) CCCCC IF(IFOUND.EQ.'NO') CCCCC1CALL DPRCIS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, CCCCC1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRCS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1290 GOTO1900 C 1270 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPRSSU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPRSSL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) CCCCC IF(IFOUND.EQ.'NO') CCCCC1CALL DPRSSN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, CCCCC1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRSN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) CCCCC IF(IFOUND.EQ.'NO') CCCCC1CALL DPRSSS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, CCCCC1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRSS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1290 GOTO1900 C 1280 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPRCSU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPRCSL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRCSN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) CCCCC IF(IFOUND.EQ.'NO') CCCCC1CALL DPRCSS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, CCCCC1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO') 1CALL DPRCS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1290 GOTO1900 C 1290 CONTINUE C C ************************************* C ** STEP 3.2-- ** C ** TREAT THE GREEK ALPHABET CASE ** C ************************************* C 1300 CONTINUE IF(IFONT.EQ.'SIMP')GOTO1310 GOTO1340 C 1310 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPGSU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPGSL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1390 GOTO1900 C 1340 CONTINUE IFOUND='NO' IF(ICASE.EQ.'UPPE') 1CALL DPGCU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(ICASE.EQ.'LOWE') 1CALL DPGCL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'NO')GOTO1390 GOTO1900 C 1390 CONTINUE C C *********************************** C ** STEP 3.3-- ** C ** TREAT THE MATH SYMBOLS CASE ** C *********************************** C 1400 CONTINUE C 1410 CONTINUE IFOUND='NO' CALL DPMATH(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 1IBUG,IFOUND,IERROR) IF(IFOUND.EQ.'YES')IMATH='YES' IF(IFOUND.EQ.'NO')GOTO1490 GOTO1900 C 1490 CONTINUE C CCCCC **************************************** CCCCC ** STEP 3.4-- ** CCCCC ** IF NO MATCH FOUND, ** CCCCC ** THEN WRITE OUT AN ERROR MESSAGE. ** CCCCC **************************************** C C1500 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1511) C1511 FORMAT('***** ERROR IN DPSCR8--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1512) C1512 FORMAT(' NO MATCH FOUND IN AVAILABLE HERSHEY ') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1513) C1513 FORMAT(' SYMBOL SETS FOR THE GIVEN INPUT CHARACTER.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1514)ICHAR2 C1514 FORMAT(' INPUT CHARACTER = ',A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1515)IFONT C1515 FORMAT(' INPUT FONT = ',A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1516)ICASE C1516 FORMAT(' INPUT CASE = ',A4) CCCCC CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C CCCCC STEP 3.4-- CCCCC IF NO MATCH FOUND, CCCCC THEN DECOMPOSE ICHAR2-- CCCCC STRIP OFF CURRENT LEAD CHARACTER AND PROCESS IT. CCCCC C1500 CONTINUE CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR8')GOTO1589 CCCCC WRITE(ICOUT,1581) C1581 FORMAT('***** FROM THE MIDDLE OF DPSCR--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1582) C1582 FORMAT(' NO MATCH FOUND IN EXAMINING ICHAR3 = ',A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1583)ICHAR2,ICHAR3 C1583 FORMAT('ICHAR2,ICHAR3 = ',A4,2X,A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1584)I2,ISTART,ISTOP,IPOINT,ISTOP C1584 FORMAT('I2,ISTART,ISTOP,IPOINT,ISTOP = ',5I8) CCCCC CALL DPWRST('XXX','BUG ') C1589 CONTINUE CC CCCCC IF(IPOINT.GE.ISTOP)GOTO1570 CCCCC GOTO1580 CC C1570 CONTINUE CCCCC IERROR='YES' CCCCC GOTO9000 C1580 CONTINUE CCCCC ICHAR3=' ' CCCCC ICHAR3(1:1)=ICHAR2(IPOINT:IPOINT) CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR8')GOTO1599 CCCCC WRITE(ICOUT,1591) C1591 FORMAT('***** FROM THE MIDDLE+ OF DPSCR--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1592)ICHAR2,ICHAR3 C1592 FORMAT('ICHAR2,ICHAR3 = ',A4,2X,A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1593)I2,ISTART,ISTOP C1593 FORMAT('I2,ISTART,ISTOP = ',3I8) CCCCC CALL DPWRST('XXX','BUG ') C1599 CONTINUE CCCCC GOTO1200 C1590 CONTINUE C C **************************************************** C ** STEP XX-- ** C ** BRANCH POINT FOR A SUCCESSFUL FIND ** C ** (IN THE VARIOUS FONTS) OF ICHAR2 FROM ABOVE. ** C **************************************************** C 1900 CONTINUE C C **************************************************************** C ** STEP XX-- C ** DRAW OUT THE CHARACTER (IF IDRAW IS ON). C ** INVISIBLY DRAW OUT THE CHARACTER (TO DETERMINE LENGTH) (IF I C ** INDEX I IS THE POSITION IN THE COORDINATE VECTOR C ** INDEX J IS THE VERTEX NUMBER WITHIN A SUB-TRACE C ** C ** NOTE--(XMAXC2-XMINC2) (= 20) HERSHEY UNITS = PWIDTH (= %) DA C ** FOR BOTH FIXED SPACING AND PROPORTIONAL SPACING. C ** THEREFORE TO TRANSLATE A HERSHEY DIFFERENCE C ** INTO A DATAPLOT (0 TO 100% UNITS) DIFFERENCE, C ** MULTIPLY THE HERSHEY DIFFERENCE BY PWIDTH/(XMAXC2-XMINC2) C ** = PWIDTH/20 C **************************************************************** C 2000 CONTINUE C C NOTE--THE VALUES -8 TO 8 ARE THE ACTUAL HERSHEY C WIDTH OF THE ROMAN SIMPLEX UPPER CASE A C AND -9 TO 12 ARE THE ACTUAL HERESHEY HEIGHT C OF THE ROMAN SIMPLEX UPPER CASE A. C XMINC=IXMINC XMAXC=IXMAXC C CCCCC XMINC2=(-10.0) CCCCC XMAXC2=10.0 XMINC2=(-8.0) XMAXC2=8.0 IF(IMATH.EQ.'YES')XMINC2=XMINC IF(IMATH.EQ.'YES')XMAXC2=XMAXC YMINC2=(-9.0) YMAXC2=12.0 CCCCC IF(IMATH.EQ.'YES')YMINC2=(-10.0) CCCCC IF(IMATH.EQ.'YES')YMAXC2=10.0 IF(IMATH.EQ.'YES')YMINC2=XMINC IF(IMATH.EQ.'YES')YMAXC2=XMAXC C XFACHP=PWIDTH/(XMAXC2-XMINC2) YFACHP=PHEIGH/(YMAXC2-YMINC2) C I=0 J=0 2500 CONTINUE I=I+1 IF(I.GT.NUMCO)GOTO2580 IF(IOP(I).EQ.'MOVE')GOTO2510 GOTO2530 C 2510 CONTINUE NPTEMP=J IFIG='LINE' IF(J.GE.1.AND.IDRAW.EQ.'ON')GOTO2520 GOTO2529 2520 CONTINUE IFLAG='ON' CCCCC CALL GRDRPL(PX,PY,NPTEMP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NPTEMP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C CCCCC NP=NPTEMP CCCCC PPENTH=0.1 CCCCC NLOOP=((PTHICK/(2.0*PPENTH))-1.0)+0.1 CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') CCCCC1WRITE(ICOUT,3521)PPENTH,NLOOP C3521 FORMAT('PPENTH,NLOOP = ',E15.7,I8) CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') CCCCC1CALL DPWRST('XXX','BUG ') CCCCC IF(NLOOP.LE.0)GOTO3529 CCCCC DO3522K=1,NLOOP CCCCC AK=K CCCCC DEL=PPENTH*AK CCCCC CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) CCCCC CALL GRDRPL(PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CCCCC DEL=(-PPENTH*AK) CCCCC CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) CCCCC CALL GRDRPL(PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 3522 CONTINUE 3529 CONTINUE C C ********************************* C ** FILL (CERTAIN) CHARACTERS ** C ********************************* C IF(IFILL.EQ.'OFF')GOTO2528 NPTEM2=NPTEMP C OCTOBER 1991. FOLLOWING CODE MODIFIED TO RECOGNIZE CHARACTER ABREVIATIONS. C SPECIFICALLY, ADDED TR, SQ, DI IF(ICHAR2.EQ.'TRIA')GOTO2521 IF(ICHAR2.EQ.'TR')GOTO2521 IF(ICHAR2.EQ.'SQUA')GOTO2521 IF(ICHAR2.EQ.'SQ')GOTO2521 IF(ICHAR2.EQ.'DIAM')GOTO2521 IF(ICHAR2.EQ.'DI')GOTO2521 IF(ICHAR2.EQ.'HEXA')GOTO2521 IF(ICHAR2.EQ.'CIRC')GOTO2521 IF(ICHAR2.EQ.'CI')GOTO2521 IF(ICHAR2.EQ.'CUBE')NPTEM2=5 IF(ICHAR2.EQ.'CUBE')GOTO2521 IF(ICHAR2.EQ.'PYRA')NPTEM2=4 IF(ICHAR2.EQ.'PYRA')GOTO2521 C C FOLLOWING 6 LINES ADDED AUGUST 1992. IF(ICHAR2.EQ.'REVT')GOTO2521 IF(ICHAR2.EQ.'TRIR')GOTO2521 IF(ICHAR2.EQ.'TRII')GOTO2521 IF(ICHAR2.EQ.'RT ')GOTO2521 IF(ICHAR2.EQ.'ARRO')GOTO2521 IF(ICHAR2.EQ.'ARRH')GOTO2521 GOTO2528 C 2521 CONTINUE CCCCC NP=NPTEMP ???? APRIL 28, 1987 NP=NPTEM2 IFLAG='LOOP' CCCCC PPENTH=0.1 CCCCC NLOOP=((PHEIGH/(2.0*PPENTH))-1.0)+0.1 CALL DPDRPL(PX,PY,NPTEM2, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') CCCCC1WRITE(ICOUT,2522)PWIDTH,PPENTH,NLOOP C2522 FORMAT('PWIDTH,PPENTH,NLOOP = ',2E15.7,I8) CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') CCCCC1CALL DPWRST('XXX','BUG ') C CCCCC IF(NLOOP.LE.0)GOTO2528 CCCCC DO2523I=1,NLOOP CCCCC AI=I CCCCC DEL=PPENTH*AI CCCCC CALL GRDEPL(PX,PY,NPTEMP,DEL,PX3,PY3,NP3) ???? APRIL 28, 1987 C CALL GRDEPL(PX,PY,NPTEM2,DEL,PX3,PY3,NP3) (THIS IS THE GOOD ONE) CCCCC CALL GRDRPL(PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) C2523 CONTINUE 2528 CONTINUE C 2529 CONTINUE J=0 GOTO2530 C 2530 CONTINUE J=J+1 CCCCC X2=X(I)-XMINC2 CCCCC IF(ISPAC.EQ.'PROP')X2=X(I)-XMINC X2=X(I)-XMINC Y2=Y(I)-YMINC2 X3=X2*XFACHP Y3=Y2*YFACHP X5=XSTAR2+X3 Y5=YSTAR2+Y3 CALL DPROTA(X5,Y5,XSTAR2,YSTAR2,ANGLE,AMAX,X6,Y6) PX(J)=X6 PY(J)=Y6 GOTO2500 C 2580 CONTINUE NPTEMP=J IF(J.GE.1.AND.IDRAW.EQ.'ON')GOTO2590 GOTO2599 2590 CONTINUE IFLAG='ON' CCCCC CALL GRDRPL(PX,PY,NPTEMP, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) CALL DPDRPL(PX,PY,NPTEMP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C CCCCC NP=NPTEMP CCCCC PPENTH=0.1 CCCCC NLOOP=((PTHICK/(2.0*PPENTH))-1.0)+0.1 CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') CCCCC1WRITE(ICOUT,4521)PPENTH,NLOOP C4521 FORMAT('PPENTH,NLOOP = ',E15.7,I8) CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') CCCCC1CALL DPWRST('XXX','BUG ') CCCCC IF(NLOOP.LE.0)GOTO4529 CCCCC DO4522K=1,NLOOP CCCCC AK=K CCCCC DEL=PPENTH*AK CCCCC CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) CCCCC CALL GRDRPL(PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCC 1JPATT,JTHICK,PTHIC2,JCOL) CCCCC DEL=(-PPENTH*AK) CCCCC CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) CCCCC CALL GRDRPL(PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL, CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 4522 CONTINUE 4529 CONTINUE C C ********************************* C ** FILL (CERTAIN) CHARACTERS ** C ********************************* C C OCTOBER 1991. FOLLOWING CODE MODIFIED TO RECOGNIZE CHARACTER ABREVIATIONS. C SPECIFICALLY, ADDED TR, SQ, DI IF(IFILL.EQ.'OFF')GOTO2598 NPTEM2=NPTEMP IF(ICHAR2.EQ.'TRIA')GOTO2591 IF(ICHAR2.EQ.'TR')GOTO2591 IF(ICHAR2.EQ.'SQUA')GOTO2591 IF(ICHAR2.EQ.'SQ')GOTO2591 IF(ICHAR2.EQ.'DIAM')GOTO2591 IF(ICHAR2.EQ.'DI')GOTO2591 IF(ICHAR2.EQ.'HEXA')GOTO2591 IF(ICHAR2.EQ.'CIRC')GOTO2591 IF(ICHAR2.EQ.'CI')GOTO2591 IF(ICHAR2.EQ.'CUBE')NPTEM2=5 IF(ICHAR2.EQ.'CUBE')GOTO2591 IF(ICHAR2.EQ.'PYRA')NPTEM2=4 IF(ICHAR2.EQ.'PYRA')GOTO2591 C C FOLLOWING 6 LINES ADDED AUGUST 1992. IF(ICHAR2.EQ.'REVT')GOTO2591 IF(ICHAR2.EQ.'TRIR')GOTO2591 IF(ICHAR2.EQ.'TRII')GOTO2591 IF(ICHAR2.EQ.'RT ')GOTO2591 IF(ICHAR2.EQ.'ARRO')GOTO2591 IF(ICHAR2.EQ.'ARRH')GOTO2591 GOTO2598 C 2591 CONTINUE IHORPA='OFF' IVERPA='ON' IDUPPA='OFF' IDDOPA='OFF' PXSPA2=0.1 PYSPA2=0.1 ICOLF=ICOL JCOLF=JCOL ICOLP=ICOL JCOLP=JCOL CCCCC CALL GRFIRE(PX,PY,NPTEMP,IFIG, CCCCC1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2, CCCCC1PTHICK,JTHICK,PTHIC2, CCCCC1ICOLF,JCOLF,ICOLP,JCOLP) CALL GRFIRE(PX,PY,NPTEM2,IFIG, 1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2, 1PTHICK,JTHICK,PTHIC2, 1ICOLF,JCOLF,ICOLP,JCOLP, 1IPATT2) 2598 CONTINUE C 2599 CONTINUE C C X2 IS THE WIDTH OF THE CHARACTER (NO SPACING) IN HERSHEY UNITS C X3 IS THE WIDTH OF THE CHARACTER (NO SPACING) IN DATAPLOT UNITS C X4 IS THE WIDHT OF THE CHARACTER + SPACING IN DATAPLOT UNITS C X2=XMAXC2-XMINC2 IF(ISPAC.EQ.'PROP')X2=XMAXC-XMINC X3=X2*XFACHP X4=X3+PHOGAP X5=XSTAR2+X4 Y5=YSTAR2 CALL DPROTA(X5,Y5,XSTAR2,YSTAR2,ANGLE,AMAX,X6,Y6) XEND2=X6 YEND2=Y6 C C **************************************************************** C ** STEP 3.6-- C ** ARE WE DECOMPOSING ICHAR2 CHARACTER BY CHARACTER? (USUALLY N C ** IF NOT, THEN EXIT. C ** IF SO, ARE WE DONE? C **************************************************************** C CCCCC IF(ISTART.GE.ISTOP)GOTO2690 CCCCC ISTART=ISTART+1 CCCCC ICHAR3(1:1)=ICHAR2(ISTART:ISTART) CCCCC XSTAR2=XEND2 CCCCC YSTAR2=YEND2 CCCCC GOTO1200 C2690 CONTINUE XEND=XEND2 YEND=YEND2 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C C 9000 CONTINUE C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR8')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('****** AT THE END OF DPSCR8--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)XSTART,YSTART,XEND,YEND 9012 FORMAT('XSTART,YSTART,XEND,YEND = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)ANUMHP,ANUMVP 9019 FORMAT('ANUMHP,ANUMVP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)ICOL,JCOL,PTHICK,JTHICK,PTHIC2 9020 FORMAT('ICOL,JCOL,PTHICK,JTHICK,PTHIC2 = ', 1A4,I8,E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)ICHAR2,IDRAW,IFONT,ICASE 9024 FORMAT('ICHAR2,IDRAW,IFONT,ICASE = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)ANGLE,AMAX 9025 FORMAT('ANGLE,AMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9035)IPATT,JPATT 9035 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9036)ISPAC 9036 FORMAT('ISPAC = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9037)IFILL 9037 FORMAT('IFILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9038)PHEIGH,PWIDTH,PVEGAP,PHOGAP 9038 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9039)PHEIG2,PWIDT2,PVEGA2,PHOGA2 9039 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9040)IMATH 9040 FORMAT('IMATH = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)XMINC,XMAXC 9041 FORMAT('XMINC,XMAXC = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)XMINC2,XMAXC2,YMINC2,YMAXC2 9042 FORMAT('XMINC2,XMAXC2,YMINC2,YMAXC2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)XFACHP,YFACHP 9043 FORMAT('XFACHP,YFACHP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)X2,X3,X4,X5,X6 9044 FORMAT('X2,X3,X4,X5,X6 = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9045)Y5,Y6 9045 FORMAT('Y5,Y6 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9046)XSTART,XEND 9046 FORMAT('XSTART,XEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9047)YSTART,YEND 9047 FORMAT('YSTART,YEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)XSTAR2,XEND2 9051 FORMAT('XSTAR2,XEND2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)YSTAR2,YEND2 9052 FORMAT('YSTAR2,YEND2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9053)ICHAR2,ICHAR3 9053 FORMAT('ICHAR2,ICHAR3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9054)IENTRY C9054 FORMAT('IENTRY = ',I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9056)PWIDTH,PPENTH,NLOOP 9056 FORMAT('PWIDTH,PPENTH,NLOOP = ',2E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9059)IFOUND,IBUGG4,ISUBG4,IERROR 9059 FORMAT('IFOUND,IBUGG4,ISUBG4,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSDCL(IHARG,NUMARG,IDSDCO,ISDFCO,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE 3-D SIDEFACE. C THE COLOR FOR THE SIDEFACE WILL BE PLACED C IN THE CHARACTER VARIABLE ISDFCO. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDSDCO C OUTPUT ARGUMENTS--ISDFCO C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDSDCO CHARACTER*4 ISDFCO CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.EQ.1)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE ISDFCO=IDSDCO GOTO1180 C 1160 CONTINUE ISDFCO=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)ISDFCO 1181 FORMAT('THE (3-D) SIDEFACE COLOR ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPSDF(IHARG,NUMARG,ISDFSW,IFOUND,IERROR) C C PURPOSE--DEFINE THE 3-D SIDEFACE SWITCH ISDFSW. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--ISDFSW ('ON' OR 'OFF') C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 ISDFSW CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160 GOTO1199 C 1150 CONTINUE ISDFSW='ON' GOTO1180 C 1160 CONTINUE ISDFSW='OFF' GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)ISDFSW 1181 FORMAT('THE (3-D) SIDEFACE SWITCH ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPSDGC(IHARG,NUMARG,IDSDGC,ISDFGC,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE 3-D SIDEFACE GRID. C THE COLOR FOR THE SIDEFACE GRID WILL BE PLACED C IN THE CHARACTER VARIABLE ISDFGC. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDSDGC C OUTPUT ARGUMENTS--ISDFGC C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGPON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDSDGC CHARACTER*4 ISDFGC CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.1)GOTO1199 IF(NUMARG.EQ.2)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE ISDFGC=IDSDGC GOTO1180 C 1160 CONTINUE ISDFGC=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)ISDFGC 1181 FORMAT('THE (3-D) SIDEFACE GRID COLOR ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPSDGP(IHARG,NUMARG,IDSDGP,ISDFGP,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN FOR THE 3-D SIDEFACE GRID. C THE PATTERN FOR THE SIDEFACE GRID WILL BE PLACED C IN THE CHARACTER VARIABLE ISDFGP. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDSDGP C OUTPUT ARGUMENTS--ISDFGP C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGPON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDSDGP CHARACTER*4 ISDFGP CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.1)GOTO1199 IF(NUMARG.EQ.2)GOTO1160 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170 GOTO1175 C 1150 CONTINUE ISDFGP='SOLI' GOTO1180 C 1160 CONTINUE ISDFGP='BLAN' GOTO1180 C 1170 CONTINUE ISDFGP=IDSDGP GOTO1180 C 1175 CONTINUE ISDFGP=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)ISDFGP 1181 FORMAT('THE (3-D) SIDEFACE GRID PATTERN ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPSDGR(IHARG,NUMARG,IDSDGR,ISDFGR,IFOUND,IERROR) C C PURPOSE--DEFINE THE 3-D SIDEFACE GRID SWITCH ISDFGR. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDSDGR C OUTPUT ARGUMENTS--ISDFGR ('ON' OR 'OFF') C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDSDGR CHARACTER*4 ISDFGR CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.EQ.1)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170 GOTO1199 C 1150 CONTINUE ISDFGR='ON' GOTO1180 C 1160 CONTINUE ISDFGR='OFF' GOTO1180 C 1170 CONTINUE ISDFGR=IDSDGR GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)ISDFGR 1181 FORMAT('THE (3-D) SIDEFACE GRID SWITCH ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPSEAR(IANSLC,IWIDTH,IHARG,IHARG2,NUMARG,ISEART, 1ICOM3,ICOM4,ICOM5,NUMCOM,NCOM5, CCCCC FEBRUARY 2003: ADD FOLLOWING LINE TO CALL LIST 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--SEARCH A USER-DEFINED FILE C FOR A USER-DEFINED STRING C AND PRINT ALL LINES WHERE THAT C STRING OCCURS. C ALSO--IF CALLED FOR, SEARCH THE MASTER REFERENCE FILE C (WHICH IS A FILE CONTAINING LISTS OF FILE NAMES) C FOR DATA FILE NAMES, FOR REFERENCE FILE NAMES, C AND FOR MACRO FILE NAMES. C ALSO--IF CALLED FOR, SEARCH THE DICTIONARY FILE C (WHICH IS A FILE CONTAINING THE LIST OF COMMANDS, C FUNCTIONS, LET SUBCOMMANDS, AND OTHER KEYWORDS.) C NOTE--THIS SUBROUTINE USES THE SAME FILE AS LIST. 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/1 C ORIGINAL VERSION--JANUARY 1988. C UPDATED --AUGUST 1988. (CHANGE DPMASF TO DPDIRF) C UPDATED --AUGUST 1988. (DICTIONARY FILE) C UPDATED --JANUARY 1994. SEARCH1 (1LIN) C UPDATED --FEBRUARY 2003. STORE LINE NUMBER OF FIRST MATCH C IN INTERNAL PARAMETER "LINENUMB". C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IANSLC CHARACTER*4 IHARG CHARACTER*4 IHARG2 C CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE C CHARACTER*4 ISEART CHARACTER*4 ICOM3 CHARACTER*4 ICOM4 CHARACTER*40 ICOM5 CHARACTER*4 IBUGS2 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 ICASEQ C CHARACTER*4 IANSI CHARACTER*80 ICANS CHARACTER*80 ISTRIN CHARACTER*80 ISTRIU CCCCC CHARACTER*40 ICJUNK C CHARACTER*80 ITAST CHARACTER*80 ITASTU CHARACTER*4 IHIT CHARACTER*4 IGO CHARACTER*4 IH CHARACTER*4 IH2 C DIMENSION IANSLC(*) C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION VALUE(*) DIMENSION IVALUE(*) C DIMENSION ICOM3(*) DIMENSION ICOM4(*) DIMENSION ICOM5(*) DIMENSION NCOM5(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOF2.INC' INCLUDE 'DPCOHO.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSE' ISUBN2='AR ' C IFOUND='YES' IERROR='NO' C MINN2=1 NCSTRI=(-999) C IHIT='NO' IGO='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SEAR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSEAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR 53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IWIDTH 54 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,55)(IANSLC(I),I=1,IWIDTH) 55 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)ISEART 56 FORMAT('ISEART = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ILISNU 61 FORMAT('ILISNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)ILISNA 62 FORMAT('ILISNA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)ILISST 63 FORMAT('ILISST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)ILISFO 64 FORMAT('ILISFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)ILISAC 65 FORMAT('ILISAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)ILISFO 66 FORMAT('ILISFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)ILISCS 67 FORMAT('ILISCS = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IDIRNU 71 FORMAT('IDIRNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IDIRNA 72 FORMAT('IDIRNA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)IDIRST 73 FORMAT('IDIRST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)IDIRFO 74 FORMAT('IDIRFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)IDIRAC 75 FORMAT('IDIRAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)IDIRFO 76 FORMAT('IDIRFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)IDIRCS 77 FORMAT('IDIRCS = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81)IDICNU 81 FORMAT('IDICNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,82)IDICNA 82 FORMAT('IDICNA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)IDICST 83 FORMAT('IDICST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)IDICFO 84 FORMAT('IDICFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,85)IDICAC 85 FORMAT('IDICAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86)IDICFO 86 FORMAT('IDICFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,87)IDICCS 87 FORMAT('IDICCS = ',A12) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************** C ** STEP 11-- ** C ** COPY OVER VARIABLES ** C ************************** C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNIT=ILISNU IFILE=ILISNA ISTAT=ILISST IFORM=ILISFO IACCES=ILISAC IPROT=ILISPR ICURST=ILISCS C ISUBN0='SEAR' IERRFI='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SEAR')GOTO1199 WRITE(ICOUT,1193)IOUNIT 1193 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1194)IFILE 1194 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 1A12,2X,A12,2X,A12,2X,A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1196)ISUBN0,IERRFI 1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 1199 CONTINUE C C *********************************************** C ** STEP 12-- ** C ** CHECK TO SEE IF THE LIST FILE MAY EXIST ** C *********************************************** C ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 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('***** IMPLEMENTATION ERROR IN DPSEAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE DESIRED SEARCHING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' CANNOT BE CARRIED OUT BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' THE INTERNAL VARIABLE ILISST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' WHICH ALLOWS SUCH SEARCHING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' HAS BEEN SET TO NONE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)ISTAT,ILISST 1217 FORMAT('ISTAT,ILISST = ',A12,2X,A12) CALL DPWRST('XXX','BUG ') GOTO9000 1290 CONTINUE C C ******************************** C ** STEP 13-- ** C ** EXTRACT THE FILE NAME. ** C ** DO THE GENERAL CASE OF ** C ** SEARCHING GENERAL FILES. ** C ** DO ALSO THE SPECIAL CASE ** C ** OF SEARCHING THE ** C ** MASTER DIRECTORY FILE. ** C ** DO ALSO THE SPECIAL CASE ** C ** OF SEARCHING THE ** C ** DICTIONARY FILE. ** C ******************************** C ISTEPN='13' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1310I=1,80 IANSI=IANSLC(I) ICANS(I:I)=IANSI(1:1) 1310 CONTINUE C ISTART=1 ISTOP=IWIDTH IWORD=2 CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,IFILE,NCFILE, 1IBUGS2,ISUBRO,IERROR) C IF(NCFILE.EQ.9.AND.IFILE.EQ.'DIRECTORY')GOTO1320 IF(NCFILE.EQ.9.AND.IFILE.EQ.'directory')GOTO1320 C IF(NCFILE.EQ.6.AND.IFILE.EQ.'MASTER')GOTO1320 IF(NCFILE.EQ.6.AND.IFILE.EQ.'master')GOTO1320 C IF(NCFILE.EQ.10.AND.IFILE.EQ.'DICTIONARY')GOTO1330 IF(NCFILE.EQ.10.AND.IFILE.EQ.'dictionary')GOTO1330 C GOTO1370 C 1320 CONTINUE IFILE=IDIRNA GOTO1370 C 1330 CONTINUE IFILE=IDICNA GOTO1370 C 1370 CONTINUE IF(NCFILE.GE.1)GOTO1379 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1371) 1371 FORMAT('***** ERROR IN DPSEAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1372) 1372 FORMAT(' A USER FILE NAME IS REQUIRED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1373) 1373 FORMAT(' IN THE LIST COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1374) 1374 FORMAT(' (FOR EXAMPLE, LIST PROG7.DP)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1375) 1375 FORMAT(' BUT NONE WAS GIVEN HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1376) 1376 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1377)(IANSLC(I),I=1,IWIDTH) 1377 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IF(IWIDTH.LE.0)WRITE(ICOUT,999) IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') GOTO9000 1379 CONTINUE C 1390 CONTINUE IF(IERROR.EQ.'YES')GOTO9000 C C ******************************** C ** STEP 14-- ** C ** EXTRACT THE STRING TO BE SEARCHED FOR. ** C ******************************** C ISTEPN='14' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISTART=1 ISTOP=IWIDTH IWORD=3 CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD, 1ICOLS1,ICOLS2,ITAST,NCTAST, 1IBUGS2,ISUBRO,IERROR) C CALL DPUP80(ITAST,ITASTU,IBUGS2,IERROR) C 1440 CONTINUE IF(NCTAST.GE.1)GOTO1449 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1441) 1441 FORMAT('***** ERROR IN DPSEAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1442) 1442 FORMAT(' A TARGET STRING IS REQUIRED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1443) 1443 FORMAT(' IN THE SEARCH COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1444) 1444 FORMAT(' (FOR EXAMPLE, SEARCH PHONE.TEX JONES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1445) 1445 FORMAT(' BUT NONE WAS GIVEN HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1446) 1446 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1447)(IANSLC(I),I=1,IWIDTH) 1447 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IF(IWIDTH.LE.0)WRITE(ICOUT,999) IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') GOTO9000 1449 CONTINUE C C ***************************************** C ** STEP 21-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='21' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2190 DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2120 2100 CONTINUE GOTO2190 2110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO2190 2120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO2190 2190 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SEAR')GOTO2195 WRITE(ICOUT,2191)NUMARG,ILOCQ 2191 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 2195 CONTINUE C C ********************************************* C ** STEP 22-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************* C ISTEPN='22' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO2210 IF(ICASEQ.EQ.'SUBS')GOTO2220 IF(ICASEQ.EQ.'FOR')GOTO2230 C 2210 CONTINUE DO2215I=1,MAXN ISUB(I)=1 2215 CONTINUE NQ=MAXN GOTO2270 C 2220 CONTINUE NIOLD=MAXN CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO2270 C 2230 CONTINUE NIOLD=MAXN CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR NMXFOR=IROWN GOTO2270 C 2270 CONTINUE IF(NQ.GE.MINN2)GOTO2290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2271) 2271 FORMAT('***** ERROR IN DPSEAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2272) 2272 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2273) 2273 FORMAT(' THE NUMBER OF SPECIFIED FILE LINES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2274) 2274 FORMAT(' TO BE LISTED ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2276)MINN2 2276 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2277) 2277 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2278) 2278 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2279)(IANSLC(I),I=1,IWIDTH) 2279 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2290 CONTINUE NS=NQ C C ************************** C ** STEP 51-- ** C ** OPEN THE FILE ** C ************************** C ISTEPN='31' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 1WRITE(ICOUT,3111)IFILE 3111 FORMAT('IFILE = ',A80) IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 1CALL DPWRST('XXX','BUG ') C IREWIN='ON' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 C 3190 CONTINUE C C ************************************* C ** STEP 41-- ** C ** READ A GENERAL FILE. ** C ** SEARCH FOR THE STRING. ** C ** IF FOUND, PRINT THE LINE OUT. ** C ** PRINT ALL LINES ON WHICH THE ** C ** STRING OCCURS. ** C ************************************* C ISTEPN='41' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IMAX=1000000 IF(ICASEQ.EQ.'SUBS')IMAX=MAXN IF(ICASEQ.EQ.'FOR')IMAX=IROWN C ILISAV=-1 C DO4110I=1,IMAX C ILICUR=I C READ(IOUNIT,4111,END=4190)(ISTRIN(J:J),J=1,80) 4111 FORMAT(80A1) CALL DPDB80(ISTRIN,JMAX,IBUGS2,ISUBRO,IERROR) NCSTRI=JMAX C CALL DPUP80(ISTRIN,ISTRIU,IBUGS2,IERROR) C IF(NCSTRI.EQ.3.AND.ISTRIN(1:3).EQ.'EOF')GOTO4190 GOTO4115 C 4115 CONTINUE IF(ICASEQ.EQ.'FULL') 1GOTO4116 IF(ICASEQ.EQ.'SUBS'.OR.ICASEQ.EQ.'FOR'.AND.ISUB(I).EQ.1) 1GOTO4116 GOTO4110 C 4116 CONTINUE C CCCCC THE FOLLOWING SECTIONS WERE REWRITTEN JANUARY 1994 IHIT='NO' IF(ISEART.EQ.'1LIN')IGO='NO' CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1994 IF(ISEART.EQ.'FIRS')IGO='NO' IF(ISEART.EQ.'BLAN'.AND.NCSTRI.LE.0)IGO='NO' IF(ISEART.EQ.'----'.AND.ISTRIN(1:4).EQ.'----')IGO='NO' IF(IGO.EQ.'YES')GOTO4129 C IF(NCSTRI.LE.0)GOTO4129 DO4120I1=1,NCSTRI I2=I1+NCTAST-1 IF(I2.GT.NCSTRI)GOTO4129 IF(ISTRIN(I1:I2).EQ.ITAST(1:NCTAST))IHIT='YES' IF(ISTRIU(I1:I2).EQ.ITASTU(1:NCTAST))IHIT='YES' IF(IHIT.EQ.'YES')IGO='YES' IF(IHIT.EQ.'YES'.AND.ILISAV.LT.0)ILISAV=ILICUR IF(IHIT.EQ.'YES')GOTO4129 4120 CONTINUE 4129 CONTINUE C IF(IHIT.EQ.'YES'.OR.IGO.EQ.'YES')THEN WRITE(ICOUT,4117)(ISTRIN(J:J),J=1,NCSTRI) 4117 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IF(IHIT.EQ.'YES'.AND.ISEART.EQ.'FIRS')GOTO4190 C 4110 CONTINUE C 4190 CONTINUE C IH='LINE' IH2='NUMB' VALUE0=REAL(ILISAV) CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANSLC,IWIDTH,IBUGS2,IERROR) C C ************************** C ** STEP 51-- ** C ** CLOSE THE FILE ** C ************************** C ISTEPN='51' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 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) C 5190 CONTINUE C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SEAR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSEAR--') 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,9033)ISEART 9033 FORMAT('ISEART = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)ICASEQ,NQ,NS 9041 FORMAT('ICASEQ,NQ,NS = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)JMAX,NCSTRI 9042 FORMAT('JMAX,NCSTRI = ',2I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSECL(IHARG,IARGT,IARG,NUMARG,IDEFCO, 1MAXSEG,ISEGCO,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR A SEGMENT. C THE COLOR FOR SEGMENT I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ISEGCO(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFCO C --MAXSEG C OUTPUT ARGUMENTS--ISEGCO (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C COLOR FOR SEGMENT I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--SEPTEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFCO CHARACTER*4 ISEGCO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION ISEGCO(*) 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.'COLO')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLO')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFCO GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXSEG ISEGCO(I)=IHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)ISEGCO(I) 1136 FORMAT('ALL SEGMENT COLORS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPSECL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE SEGMENT ... COLOR COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE SEGMENT IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' SEGMENT 3 COLOR GREEN') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXSEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPSECL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE SEGMENT ... COLOR COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF SEGMENTS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXSEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'SEGMENT.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFCO GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' ISEGCO(I)=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,ISEGCO(I) 1186 FORMAT('THE COLOR FOR SEGMENT ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPSECO(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH, 1MAXSEG,PSEGXC,PSEGYC,NUMSEG,IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE 2 PAIRS OF (X,Y) COORDINATES C FOR A LINE SEGMENT. C THE FIRST PAIR WILL BE FOR THE TAIL OF THE SEGMENT; C THE SECOND PAIR WILL BE FOR THE HEAD OF THE SEGMENT. C THE (X1,Y1), (X2,Y2) COORDINATES WILL BE PLACED IN THE C FIRST AND SECOND ELEMENTS (RESPECTIVELY) OF C THE 2 SEGAYS PSEGXC(.,.) AND PSEGYC(.,.) C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A HOLLERITH VECTOR) C --NUMARG C --MAXSEG C OUTPUT ARGUMENTS--PSEGXC (A FLOATING POINT VECTOR C WHOSE (I,1)-TH ELEMENT CONTAINS THE C X COORDINATE FOR THE TAIL OF SEGMENT I; C WHOSE (I,2)-TH ELEMENT CONTAINS THE C X COORDINATE FOR THE HEAD OF SEGMENT I; C --PSEGYC (A FLOATING POINT VECTOR C WHOSE (I,1)-TH ELEMENT CONTAINS THE C Y COORDINATE FOR THE TAIL OF SEGMENT I; C WHOSE (I,2)-TH ELEMENT CONTAINS THE C Y COORDINATE FOR THE HEAD OF SEGMENT I; C --NUMSEG = THE NUMBER OF SEGMENTS DEFINED SO FAR C (ACTUALLY, THE HIGHEST REFERENCED SEGMENT SO FAR) 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--SEPTEMBER 1980. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IANS CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHWORD CHARACTER*4 IHWOR2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IN(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IANS(*) C DIMENSION PSEGXC(100,2) DIMENSION PSEGYC(100,2) 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='DPAR' ISUBN2='CO ' C IFOUND='NO' IERROR='NO' C HOLD1=0.0 HOLD2=0.0 HOLD3=0.0 HOLD4=0.0 C IF(NUMARG.EQ.0)GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COOR')GOTO1140 GOTO9000 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 IF(NUMARG.GE.5)GOTO1125 C IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPSECO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' IN THE SEGMENT ... COORDINATES COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' THE COORDINATES ARE SPECIFIED BY 4 NUMBERS, ', 1'AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' SEGMENT 3 COORDINATES 30 80 31 79') CALL DPWRST('XXX','BUG ') GOTO9000 C 1120 CONTINUE HOLD1=CPUMIN HOLD2=CPUMIN HOLD3=CPUMIN HOLD4=CPUMIN NUMSEG=0 GOTO1130 C 1125 CONTINUE DO1126J=2,5 IF(IARGT(J).EQ.'NUMB')GOTO1127 GOTO1128 1127 CONTINUE IF(J.EQ.2)HOLD1=ARG(J) IF(J.EQ.3)HOLD2=ARG(J) IF(J.EQ.4)HOLD3=ARG(J) IF(J.EQ.5)HOLD4=ARG(J) GOTO1126 1128 CONTINUE IHWORD=IHARG(J) IHWOR2=IHARG2(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(J.EQ.2)HOLD1=VALUE(ILOC) IF(J.EQ.3)HOLD2=VALUE(ILOC) IF(J.EQ.4)HOLD3=VALUE(ILOC) IF(J.EQ.5)HOLD4=VALUE(ILOC) 1126 CONTINUE NUMSEG=MAXSEG GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXSEG PSEGXC(I,1)=HOLD1 PSEGYC(I,1)=HOLD2 PSEGXC(I,2)=HOLD3 PSEGYC(I,2)=HOLD4 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136) 1136 FORMAT('ALL SEGMENT COORDINATES HAVE JUST BEEN SET TO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137)PSEGXC(I,1),PSEGYC(I,1) 1137 FORMAT(' (X,Y) FOR TAIL OF SEGMENT = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138)PSEGXC(I,2),PSEGYC(I,2) 1138 FORMAT(' (X,Y) FOR HEAD OF SEGMENT = ',2E15.7) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO9000 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPSECO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE SEGMENT ... COORDINATES COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE SEGMENT IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' SEGMENT 3 COORDINATES 30 80 31 79') CALL DPWRST('XXX','BUG ') GOTO9000 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXSEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPSECO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE SEGMENT ... COORDINATES COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF SEGMENTS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXSEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'SEGMENT.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 IF(NUMARG.GE.6)GOTO1175 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) CALL DPWRST('XXX','BUG ') GOTO9000 C 1170 CONTINUE HOLD1=CPUMIN HOLD2=CPUMIN HOLD3=CPUMIN HOLD4=CPUMIN IF(I.EQ.NUMSEG)NUMSEG=I-1 GOTO1180 C 1175 CONTINUE DO1176J=3,6 IF(IARGT(J).EQ.'NUMB')GOTO1177 GOTO1178 1177 CONTINUE IF(J.EQ.3)HOLD1=ARG(J) IF(J.EQ.4)HOLD2=ARG(J) IF(J.EQ.5)HOLD3=ARG(J) IF(J.EQ.6)HOLD4=ARG(J) GOTO1176 1178 CONTINUE IHWORD=IHARG(J) IHWOR2=IHARG2(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(J.EQ.3)HOLD1=VALUE(ILOC) IF(J.EQ.4)HOLD2=VALUE(ILOC) IF(J.EQ.5)HOLD3=VALUE(ILOC) IF(J.EQ.6)HOLD4=VALUE(ILOC) 1176 CONTINUE IF(I.GT.NUMSEG)NUMSEG=I GOTO1180 C 1180 CONTINUE IFOUND='YES' PSEGXC(I,1)=HOLD1 PSEGYC(I,1)=HOLD2 PSEGXC(I,2)=HOLD3 PSEGYC(I,2)=HOLD4 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I 1186 FORMAT('THE COORDINATES FOR SEGMENT ',I8, 1' HAVE JUST BEEN SET TO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137)PSEGXC(I,1),PSEGYC(I,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138)PSEGXC(I,2),PSEGYC(I,2) 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 DPSECO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSEED(IHARG,IARGT,IARG,NUMARG,IDEFSE, 1ISEED,IFOUND,IERROR) C C PURPOSE--DEFINE THE SEED (AN INTEGER) C WHICH IS USED AS INPUT IN UNIFORM RANDOM NUMBER GENERATION AND C WHICH IN TURN SERVES AS THE BASIS FOR ALL RANDOM NUMBER GENERATIO C THE SPECIFIED SEED VALUE WILL BE PLACED C IN THE INTEGER VARIABLE ISEED. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFSE (A FLOATING POINT VARIABLE) C OUTPUT ARGUMENTS--ISEED (AN INTEGER VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1110 CONTINUE IF(NUMARG.LE.0)GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPSEED--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR SEED ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE THE ANALYST DESIRES THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' SEED VALUE FOR RANDOM NUMBER GENERATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' TO BE 735679238,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) 1129 FORMAT(' THEN THE ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' SEED 735679238 ') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE IHOLD=IDEFSE GOTO1180 C 1160 CONTINUE IHOLD=IARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' ISEED=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)ISEED 1181 FORMAT('THE RANDOM NUMBER SEED HAS JUST BEEN SET TO ', 1I11) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END