SUBROUTINE DPMNTC(ICOM,IHARG,IARGT,ARG,NUMARG, 1X1COMN,X2COMN,Y1COMN,Y2COMN, 1NX1CMN,NX2CMN,NY1CMN,NY2CMN, 1MAXTIC, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE MINOR TIC MARK COORDINATES C FOR ANY OF THE 4 FRAME LINES. C THE MINOR TIC MARK COORDINATES ARE GIVEN IN UNITS C OF THE PLOTTED DATA. C ALSO, A SECONDARY PURPOSE IS TO ADJUST ACCORDINGLY C THE TIC MARK SWITCHES C FOR ANY OF THE 4 FRAME LINES. C SUCH TIC MARK SWITCHES TURN ON OR OFF C THE TIC MARKS ON THE 4 FRAME LINES OF A PLOT. C THE CONTENTS OF A TIC MARK SWITCH ARE C ON OR OFF C THE TIC MARK SWITCHES DEFINE WHETHER C THE TIC MARKS FOR A GIVEN FRAME SHOULD C BE ON (THAT IS, APPEAR), OR BE OFF (THAT IS, C BE SUPPRESSED. C THE TIC MARK SWITCHES FOR THE 4 FRAME LINES C ARE CONTAINED IN THE 4 VARIABLES C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG C --MAXTIC C OUTPUT ARGUMENTS-- C --X1COMN,X2COMN,Y1COMN,Y2COMN, C --NX1CMN,NX2CMN,NY1CMN,NY2CMN, C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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 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 X1COMN(*) DIMENSION X2COMN(*) DIMENSION Y1COMN(*) DIMENSION Y2COMN(*) 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 ILOCC=0 IF(NUMARG.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')ILOCC=1 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COOR')ILOCC=2 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'COOR')ILOCC=3 ILOCCP=ILOCC+1 IF(ILOCC.EQ.0)GOTO1900 C C ***************************************************** C ** TREAT THE CASE WHEN TIC MARK COORDINATES ON ** C ** BOTH HORIZONTAL FRAME LINES ARE TO BE DEFINED ** C ***************************************************** C IF(ICOM.EQ.'XTIC')GOTO1100 GOTO1199 C 1100 CONTINUE IF(ILOCC.EQ.NUMARG)GOTO1110 IF(IHARG(ILOCCP).EQ.'ON')GOTO1110 IF(IHARG(ILOCCP).EQ.'OFF')GOTO1120 IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1110 IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1110 GOTO1130 C 1110 CONTINUE IFOUND='YES' NX1CMN=-1 NX2CMN=-1 C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1115) 1115 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH HORIZONTAL ', 1'FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1116) 1116 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC') CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO1900 C 1120 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH HORIZONTAL ', 1'FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT('HAVE JUST BEEN TURNED OFF ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON THEM') CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO1900 C 1130 CONTINUE C J=0 DO1131I=ILOCCP,NUMARG J=J+1 IF(J.GT.MAXTIC)GOTO1800 IF(IARGT(I).NE.'NUMB')GOTO1850 X1COMN(J)=ARG(I) X2COMN(J)=ARG(I) 1131 CONTINUE IFOUND='YES' NX1CMN=J NX2CMN=J C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH HORIZONTAL ', 1'FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED') CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1900 C 1199 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON C ** ONLY THE BOTTOM HORIZONTAL FRAME LINE ARE TO BE DEFINED ** C ************************************************************** C IF(ICOM.EQ.'X1TI')GOTO1200 GOTO1299 C C 1200 CONTINUE IF(ILOCC.EQ.NUMARG)GOTO1210 IF(IHARG(ILOCCP).EQ.'ON')GOTO1210 IF(IHARG(ILOCCP).EQ.'OFF')GOTO1220 IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1210 IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1210 GOTO1230 C 1210 CONTINUE IFOUND='YES' NX1CMN=-1 C IF(IFEEDB.EQ.'OFF')GOTO1219 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT('THE MINOR TIC COORDINATES (FOR THE BOTTOM ', 1'HORIZONTAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC') CALL DPWRST('XXX','BUG ') 1219 CONTINUE GOTO1900 C 1220 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1229 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1225) 1225 FORMAT('THE MINOR TIC COORDINATES (FOR THE BOTTOM ', 1'HORIZONTAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1226) 1226 FORMAT('HAVE JUST BEEN TURNED OFF ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1227) 1227 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON IT)') CALL DPWRST('XXX','BUG ') 1229 CONTINUE GOTO1900 C 1230 CONTINUE C J=0 DO1231I=ILOCCP,NUMARG J=J+1 IF(J.GT.MAXTIC)GOTO1800 IF(IARGT(I).NE.'NUMB')GOTO1850 X1COMN(J)=ARG(I) 1231 CONTINUE IFOUND='YES' NX1CMN=J C IF(IFEEDB.EQ.'OFF')GOTO1239 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1235) 1235 FORMAT('THE MINOR TIC COORDINATES (FOR THE BOTTOM ', 1'HORIZONTAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1236) 1236 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED') CALL DPWRST('XXX','BUG ') 1239 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON C ** ONLY THE TOP HORIZONTAL FRAME LINE ARE TO BE DEFINED ** C ************************************************************** C IF(ICOM.EQ.'X2TI')GOTO1300 GOTO1399 C 1300 CONTINUE IF(ILOCC.EQ.NUMARG)GOTO1310 IF(IHARG(ILOCCP).EQ.'ON')GOTO1310 IF(IHARG(ILOCCP).EQ.'OFF')GOTO1320 IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1310 IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1310 GOTO1330 C 1310 CONTINUE IFOUND='YES' NX2CMN=-1 C IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT('THE MINOR TIC COORDINATES (FOR THE TOP ', 1'HORIZONTAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316) 1316 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC') CALL DPWRST('XXX','BUG ') 1319 CONTINUE GOTO1900 C 1320 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1329 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1325) 1325 FORMAT('THE MINOR TIC COORDINATES (FOR THE TOP ', 1'HORIZONTAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326) 1326 FORMAT('HAVE JUST BEEN TURNED OFF ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1327) 1327 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON IT)') CALL DPWRST('XXX','BUG ') 1329 CONTINUE GOTO1900 C 1330 CONTINUE C J=0 DO1331I=ILOCCP,NUMARG J=J+1 IF(J.GT.MAXTIC)GOTO1800 IF(IARGT(I).NE.'NUMB')GOTO1850 X2COMN(J)=ARG(I) 1331 CONTINUE IFOUND='YES' NX2CMN=J C IF(IFEEDB.EQ.'OFF')GOTO1339 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1335) 1335 FORMAT('THE MINOR TIC COORDINATES (FOR THE TOP ', 1'HORIZONTAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1336) 1336 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED') CALL DPWRST('XXX','BUG ') 1339 CONTINUE GOTO1900 C 1399 CONTINUE C C *************************************************** C ** TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON ** C ** BOTH VERMINOR TICAL FRAME LINES ARE TO BE DEFINED ** C *************************************************** C IF(ICOM.EQ.'YMINOR TIC')GOTO1400 GOTO1499 C 1400 CONTINUE IF(ILOCC.EQ.NUMARG)GOTO1410 IF(IHARG(ILOCCP).EQ.'ON')GOTO1410 IF(IHARG(ILOCCP).EQ.'OFF')GOTO1420 IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1410 IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1410 GOTO1430 C 1410 CONTINUE IFOUND='YES' NY1CMN=-1 NY2CMN=-1 C IF(IFEEDB.EQ.'OFF')GOTO1419 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415) 1415 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH ', 1'VERTICAL FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1416) 1416 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC') CALL DPWRST('XXX','BUG ') 1419 CONTINUE GOTO1900 C 1420 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1429 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1425) 1425 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH ', 1'VERTICAL FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1426) 1426 FORMAT('HAVE JUST BEEN TURNED OFF ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1427) 1427 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON THEM') CALL DPWRST('XXX','BUG ') 1429 CONTINUE GOTO1900 C 1430 CONTINUE C J=0 DO1431I=ILOCCP,NUMARG J=J+1 IF(J.GT.MAXTIC)GOTO1800 IF(IARGT(I).NE.'NUMB')GOTO1850 Y1COMN(J)=ARG(I) Y2COMN(J)=ARG(I) 1431 CONTINUE IFOUND='YES' NY1CMN=J NY2CMN=J C IF(IFEEDB.EQ.'OFF')GOTO1439 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1435) 1435 FORMAT('THE MINOR TIC MARK COORDINATES (FOR BOTH ', 1'VERTICAL FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1436) 1436 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED') CALL DPWRST('XXX','BUG ') 1439 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON C ** ONLY THE LEFT VERMINOR TICAL FRAME LINE ARE TO BE DEFINE C ************************************************************** C IF(ICOM.EQ.'Y1TI')GOTO1500 GOTO1599 C 1500 CONTINUE IF(ILOCC.EQ.NUMARG)GOTO1510 IF(IHARG(ILOCCP).EQ.'ON')GOTO1510 IF(IHARG(ILOCCP).EQ.'OFF')GOTO1520 IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1510 IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1510 GOTO1530 C 1510 CONTINUE IFOUND='YES' NY1CMN=-1 C IF(IFEEDB.EQ.'OFF')GOTO1519 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1515) 1515 FORMAT('THE MINOR TIC COORDINATES (FOR THE LEFT ', 1'VERTICAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1516) 1516 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC') CALL DPWRST('XXX','BUG ') 1519 CONTINUE GOTO1900 C 1520 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1529 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1525) 1525 FORMAT('THE MINOR TIC COORDINATE (FOR THE LEFT ', 1'VERTICAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1526) 1526 FORMAT('HAVE JUST BEEN TURNED OFF ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1527) 1527 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON IT)') CALL DPWRST('XXX','BUG ') 1529 CONTINUE GOTO1900 C 1530 CONTINUE C J=0 DO1531I=ILOCCP,NUMARG J=J+1 IF(J.GT.MAXTIC)GOTO1800 IF(IARGT(I).NE.'NUMB')GOTO1850 Y1COMN(J)=ARG(I) 1531 CONTINUE IFOUND='YES' NY1CMN=J C IF(IFEEDB.EQ.'OFF')GOTO1539 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1535) 1535 FORMAT('THE MINOR TIC COORDINATES (FOR THE LEFT ', 1'VERTICAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1536) 1536 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED') CALL DPWRST('XXX','BUG ') 1539 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON C ** ONLY THE RIGHT VERTCIAL FRAME LINE ARE TO BE DEFINED ** C ************************************************************** C IF(ICOM.EQ.'Y2TI')GOTO1600 GOTO1699 C 1600 CONTINUE IF(ILOCC.EQ.NUMARG)GOTO1610 IF(IHARG(ILOCCP).EQ.'ON')GOTO1610 IF(IHARG(ILOCCP).EQ.'OFF')GOTO1620 IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1610 IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1610 GOTO1630 C 1610 CONTINUE IFOUND='YES' NY2CMN=-1 C IF(IFEEDB.EQ.'OFF')GOTO1619 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1615) 1615 FORMAT('THE MINOR TIC COORDINATES (FOR THE RIGHT ', 1'VERTICAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1616) 1616 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC') CALL DPWRST('XXX','BUG ') 1619 CONTINUE GOTO1900 C 1620 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1629 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1625) 1625 FORMAT('THE MINOR TIC COORDINATES (FOR THE RIGHT ', 1'VERTICAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1626) 1626 FORMAT('HAVE JUST BEEN TURNED OFF ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1627) 1627 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON IT)') CALL DPWRST('XXX','BUG ') 1629 CONTINUE GOTO1900 C 1630 CONTINUE C J=0 DO1631I=ILOCCP,NUMARG J=J+1 IF(J.GT.MAXTIC)GOTO1800 IF(IARGT(I).NE.'NUMB')GOTO1850 Y1COMN(J)=ARG(I) 1631 CONTINUE IFOUND='YES' NY2CMN=J C IF(IFEEDB.EQ.'OFF')GOTO1639 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1635) 1635 FORMAT('THE MINOR TIC COORDINATES (FOR THE RIGHT ', 1'VERTICAL FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1636) 1636 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED') CALL DPWRST('XXX','BUG ') 1639 CONTINUE GOTO1900 C 1699 CONTINUE C C ************************************************** C ** TREAT THE CASE WHEN MINOR TIC MARK COORDINATES ON ** C ** THE ENTIRE 4-SIDED FRAME ARE TO BE DEFINED ** C ************************************************** C IF(ICOM.EQ.'XYTI')GOTO1700 IF(ICOM.EQ.'YXTI')GOTO1700 IF(ICOM.EQ.'MINOR TICS')GOTO1700 IF(ICOM.EQ.'MINOR TIC ')GOTO1700 GOTO1799 C 1700 CONTINUE IF(ILOCC.EQ.NUMARG)GOTO1710 IF(IHARG(ILOCCP).EQ.'ON')GOTO1710 IF(IHARG(ILOCCP).EQ.'OFF')GOTO1720 IF(IHARG(ILOCCP).EQ.'AUTO')GOTO1710 IF(IHARG(ILOCCP).EQ.'DEFA')GOTO1710 GOTO1730 C 1710 CONTINUE IFOUND='YES' NX1CMN=-1 NX2CMN=-1 NY1CMN=-1 NY2CMN=-1 C IF(IFEEDB.EQ.'OFF')GOTO1719 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1715) 1715 FORMAT('THE MINOR TIC COORDINATES (FOR ALL 4 ', 1'FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1716) 1716 FORMAT('HAVE JUST BEEN SET TO AUTOMATIC') CALL DPWRST('XXX','BUG ') 1719 CONTINUE GOTO1900 C 1720 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1729 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1725) 1725 FORMAT('THE MINOR TIC COORDINATES (FOR ALL 4 ', 1'FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1726) 1726 FORMAT('HAVE JUST BEEN TURNED OFF ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1727) 1727 FORMAT('(THUS NO MINOR TIC MARKS WILL APPEAR ON ANY ', 1'FRAME LINE)') CALL DPWRST('XXX','BUG ') 1729 CONTINUE GOTO1900 C 1730 CONTINUE C J=0 DO1731I=ILOCCP,NUMARG J=J+1 IF(J.GT.MAXTIC)GOTO1800 IF(IARGT(I).NE.'NUMB')GOTO1850 X1COMN(J)=ARG(I) X2COMN(J)=ARG(I) Y1COMN(J)=ARG(I) Y2COMN(J)=ARG(I) 1731 CONTINUE IFOUND='YES' NX1CMN=J NX2CMN=J NY1CMN=J NY2CMN=J C IF(IFEEDB.EQ.'OFF')GOTO1739 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1735) 1735 FORMAT('THE MINOR TIC COORDINATES (FOR ALL 4 FRAMES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1736) 1736 FORMAT('HAVE JUST BEEN MANUALLY SPECIFIED') CALL DPWRST('XXX','BUG ') 1739 CONTINUE GOTO1900 C 1799 CONTINUE GOTO1900 C 1800 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1801) 1801 FORMAT('***** ERROR IN DPMNTC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1802) 1802 FORMAT(' THE NUMBER OF SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1803) 1803 FORMAT(' MINOR TIC COORDINATES HAS JUST EXCEEDED ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1804)MAXTIC 1804 FORMAT(' THE ALLOWABLE MAXIMUM OF ',I8) CALL DPWRST('XXX','BUG ') GOTO1900 C 1850 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1851) 1851 FORMAT('***** ERROR IN DPMNTC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1852) 1852 FORMAT(' A SPECIFICATION IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1853) 1853 FORMAT(' MINOR TIC COORDINATES COMMAND HAS JUST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1854) 1854 FORMAT(' BEEN ENCOUNTERED WHICH IS NON-NUMERIC') CALL DPWRST('XXX','BUG ') GOTO1900 C 1900 CONTINUE RETURN END SUBROUTINE DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGS2,IERROR) CCCCC THE IRESP ARGUMENT WAS ADDED JULY 1990 C C PURPOSE--WRITE OUT A LINE WHICH SAYS MORE... C AND PAUSE UNTIL RECEIVE A CARRIAGE RETURN C (USED BY HELP AND LIST COMMANDS) C INPUT ARGUMENTS--NUMLPR = NUMBER OF LINE PRINTED ALREADY C OUTPUT ARGUMENTS--IRESP (YES OR NO) C NOTE--IT IS TYPICAL TO HAVE A LINE C IF(NUMLPR.GE.IHELMX)NUMLPR=0 C IN THE CALLING ROUTINE IMMEDIATELY AFTER C THE CALL TO DPMORE. C NOTE--THE CALLING ROUTINE ALSO TYPICALLY HAS C NUMLPR=0 C IRESP='YES' C EARLY ON IN THE CODE FOR INITIALIZATION. C (IF OMIT IRESP='YES' THEN WILL GET MIS-EXECUTION!) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/8 C ORIGINAL VERSION--JULY 1989. C UPDATED --JULY 1989. CHAR*4 STATEMENTS FOR ISUBN1/2 C UPDATED --JULY 1990. CHANGE MORE... TO MORE...? C UPDATED --JULY 1990. ALLOW MORE... TO STOP LIST C UPDATED --FEBRUARY 1993. SKIP ALL IF TURBO-C MENU C UPDATED --SEPTEMBER 1993. ALLOW ALWAYS-WRITING C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*40 ICPREH CCCCC CHARACTER*40 ICPOSH C CHARACTER*4 IBUGS2 CHARACTER*4 IERROR C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990 CHARACTER*4 IRESP C CCCCC THE FOLLOWING 2 LINES WERE ADDED JULY 1989 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C-----COMMON---------------------------------------------------------- C CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1993 INCLUDE 'DPCODV.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='DPMO' ISUBN2='RE ' C IF(IBUGS2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPMORE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMLPR 53 FORMAT('NUMLPR = ',I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED FEBRUARY 1993 WRITE(ICOUT,54)TCMENU 54 FORMAT('TCMENU = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************* C ** TREAT THE MORE/PAUSE CASE ** C ********************************* C CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1993 IF(TCMENU.EQ.'ON')GOTO9000 C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990 IRESP='YES' C WRITE(ICOUT,1101) 1101 FORMAT(' MORE...?') CCCCC CALL DPWRST('XXX','BUG ') SEPTEMBER 1993 CALL DPWRST('XXX','WRIT') CCCCC THE FOLLOWING 2 LINES WERE MODIFIED JULY 1990 CCCCC READ(IRD,1102) C1102 FORMAT() READ(IRD,1102)IRESP 1102 FORMAT(A4) CCCCC THE FOLLOWING 4 LINES WERE ADDED JULY 1990 CCCCC MODIFIED AUGUST 1992. IF(IRESP.EQ.'N')IRESP='NO' CCCCC IF(IRESP.EQ.'NO')GOTO9000 IF(IRESP.EQ.'n')IRESP='NO' CCCCC IF(IRESP.EQ.'no')GOTO9000 IF(IRESP.EQ.'no')IRESP='NO' IF(IRESP.EQ.'NO')GOTO9000 CCCCC THE FOLLOWING LINE WAS COMMENTED OUT AUGUST 1990 CCCCC NUMLPR=0 IF(NCPREH.LE.0)GOTO1109 WRITE(ICOUT,1106)(ICPREH(J:J),J=1,NCPREH) 1106 FORMAT(80A1) CCCCC CALL DPWRST('XXX','BUG ') SEPTEMBER 1993 CALL DPWRST('XXX','WRIT') 1109 CONTINUE C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE BEGINNING OF DPMORE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMLPR 9013 FORMAT('NUMLPR = ',I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED FEBRUARY 1993 WRITE(ICOUT,9014)TCMENU 9014 FORMAT('TCMENU = ',A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED JULY 1990 WRITE(ICOUT,9015)IRESP 9015 FORMAT('IRESP = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPMOV2(X1,Y1, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--MOVE TO A POINT C WITH THE COORDINATES (X1,Y1) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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(10) DIMENSION PY(10) CCCCC DIMENSION PX3(10) CCCCC DIMENSION PY3(10) 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.'MOV2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPMOV2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)X1,Y1 53 FORMAT('X1,Y1 = ',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 POINT ** C ********************************* C PX(1)=X1 PY(1)=Y1 C NP=1 C C *********************** C ** STEP 2-- ** C ** FILL THE FIGURE ** C ** (IF CALLED FOR) ** C *********************** C IF(IREFSW(1).EQ.'OFF')GOTO2190 IPATT=IREPTY(1) IPATT2='SOLI' PTHICK=PREPTH(1) PXGAP=PREPSP(1) PYGAP=PREPSP(1) ICOLF=IREFCO(1) ICOLP=IREPCO(1) CALL DPFIRE(PX,PY,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 2190 CONTINUE C C *************************** C ** STEP 3-- ** C ** DRAW OUT THE FIGURE ** C *************************** C IPATT=ILINPA(1) PTHICK=PLINTH(1) ICOL=ILINCO(1) IFLAG='ON' CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'MOV2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPMOV2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NP 9013 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 DPMOVE(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 THE FOLLOWING LINE WAS ADDED NOVEMBER 1992 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC1UNITSW, 1X1UNIT,Y1UNIT, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--MOVE TO ONE OR MORE POINTS C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE INPUT COORDINATES DEFINE THE C POINT. C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 1 C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*1 = 2. C NOTE--IF NO NUMBERS ARE PROVIDED, C THEN THE POINT MOVED TO WILL BE C AT THE LAST CURSOR POSITION C NOTE--IF 2 NUMBERS ARE PROVIDED, C THEN THE POINT MOVED TO WILL BE C AT THE ABSOLUTE (X,Y) POSITION C AS DEFINED BY THE 2 NUMBERS C NOTE--AND SO FORTH FOR 2, 3, 4, ... 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 INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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 --NOVEMBER 1992. UNITS SWITCH (DATA OR SCREEN) C UPDATED --SEPTEMBER 1993. DECLARE DUMMY ISUBRO C UPDATED --SEPTEMBER 1993. FIX BUG FORMAT STATEMENT C UPDATED --FEBRUARY 1995. GENERALIZED MOVE.... COMMAND C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (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 C CHARACTER*4 IFOUND CHARACTER*4 IBUGD2 CHARACTER*4 IERROR C CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 CHARACTER*4 ISUBRO C CHARACTER*4 IFIG CHARACTER*4 IBELSW CHARACTER*4 IERASW CHARACTER*4 IBACCO CHARACTER*4 ICOPSW CHARACTER*4 ITYPEO C CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC CHARACTER*4 UNITSW CHARACTER*4 X1UNIT CHARACTER*4 Y1UNIT 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 CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 ISUBRO='DUMM' 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.'MOVE')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPMOVE--') 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,85)X1UNIT,Y1UNIT 85 FORMAT('X1UNIT, Y1UNIT = ',2A4) CALL DPWRST('XXX','BUG ') 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='POIN' NUMPT=1 NUMPT2=2*NUMPT C C ******************************** C ** STEP 0-- ** C ** STEP THROUGH EACH DEVICE ** C ******************************** C IF(NUMDEV.LE.0)GOTO9000 DO8000IDEVIC=1,NUMDEV C IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 C IMANUF=IDMANU(IDEVIC) IMODEL=IDMODE(IDEVIC) IMODE2=IDMOD2(IDEVIC) IMODE3=IDMOD3(IDEVIC) IGCONT=IDCONT(IDEVIC) IGCOLO=IDCOLO(IDEVIC) CCCCC ADD FOLLOWING LINE MARCH 1997. IGFONT=IDFONT(IDEVIC) NUMVPP=IDNVPP(IDEVIC) NUMHPP=IDNHPP(IDEVIC) ANUMVP=NUMVPP ANUMHP=NUMHPP C AUGUST 1988. ADD OFFSET VARIABLE IOFFSV=IDNVOF(IDEVIC) IOFFSH=IDNHOF(IDEVIC) C IGUNIT=IDUNIT(IDEVIC) C C ************************************ C ** STEP 1-- ** C ** CARRY OUT OPENING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C CALL DPOPDE C IBELSW='OFF' NUMRIN=0 IERASW='OFF' IBACCO='JUNK' C CALL DPOPPL(IGRASW, 1IBELSW,NUMRIN,IERASW, 1IBACCO) C C ***************************************** C ** STEP 2-- ** C ** SEARCH FOR COMMAND SPECIFICATIONS ** C ***************************************** C IF(NUMARG.GE.2.AND. 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1GOTO1111 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1113 GOTO1130 C 1111 CONTINUE ITYPEO='ABSO' ILOCFN=1 GOTO1119 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='RELA' ILOCFN=2 GOTO1119 1119 CONTINUE C IF(ILOCFN.GT.NUMARG)GOTO1129 DO1120I=ILOCFN,NUMARG IF(IARGT(I).EQ.'NUMB')GOTO1120 GOTO1129 1120 CONTINUE IFOUND='YES' GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPMOVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A POINT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' AT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' BOX ABSOLUTE 20 20 ') CALL DPWRST('XXX','BUG ') GOTO9000 1149 CONTINUE C C **************************** C ** STEP 3-- ** C ** MOVE TO THE POINT(S) ** C **************************** C NUMNUM=NUMARG-ILOCFN+1 IF(NUMNUM.LT.NUMPT2)GOTO1151 GOTO1152 C 1151 CONTINUE J=ILOCFN-1 X1=PXSTAR Y1=PYSTAR GOTO1170 C 1152 CONTINUE J=ILOCFN IF(J.GT.NUMARG)GOTO1190 X1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) IF(X1UNIT.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 NOVEMBER 1992 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) IF(Y1UNIT.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) GOTO1170 C 1160 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(X1UNIT.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 NOVEMBER 1992 CCCCC AND THEN CHANGED FEBRUARY 1995 CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(Y1UNIT.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 X1=X2 Y1=Y2 GOTO1170 C 1170 CONTINUE CALL DPMOV2(X1,Y1, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C X1=X1 Y1=Y1 C GOTO1160 1190 CONTINUE C PXEND=X1 PYEND=Y1 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.'MOVE')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPMOVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILOCFN,NUMNUM 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)X1,Y1 9013 FORMAT('X1,Y1 = ',2E15.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 CCCCC THE FOLLOWING LINE WAS FIXED SEPTEMBER 1993 C9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4) 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,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 DPMPCO(IHARG,NUMARG,IDEMPC,MAXMAR,IMAPCO, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE MARKER PATTERN COLORS = THE COLORS C OF THE LINES MAKING UP A PATTERN WITHIN A MARKER. C THESE ARE LOCATED IN THE VECTOR IMAPCO(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEMPC C --MAXMAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IMAPCO (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEMPC CHARACTER*4 IMAPCO 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 IMAPCO(*) 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='DPMP' ISUBN2='CO ' C NUMMAR=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 DPMPCO--') 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)MAXMAR,NUMMAR 53 FORMAT('MAXMAR,NUMMAR = ',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)IDEMPC 55 FORMAT('IDEMPC = ',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)IMAPCO(1) 70 FORMAT('IMAPCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IMAPCO(I) 76 FORMAT('I,IMAPCO(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE SINGLE SPECIFICATION CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMMAR=1 IMAPCO(1)=IDEMPC GOTO1270 C 1220 CONTINUE NUMMAR=NUMARG-2 IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR DO1225I=1,NUMMAR J=I+2 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEMPC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEMPC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPC IMAPCO(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMMAR WRITE(ICOUT,1276)I,IMAPCO(I) 1276 FORMAT('THE COLOR OF MARKER PATTERN ',I6, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 3-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMMAR=MAXMAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEMPC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEMPC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPC DO1315I=1,NUMMAR IMAPCO(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)IMAPCO(I) 1316 FORMAT('THE COLOR OF ALL MARKER PATTERNS', 1' HAS JUST BEEN SET TO ',A4) 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 DPMPCO--') 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)MAXMAR,NUMMAR 9013 FORMAT('MAXMAR,NUMMAR = ',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)IDEMPC 9015 FORMAT('IDEMPC = ',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)IMAPCO(1) 9030 FORMAT('IMAPCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IMAPCO(I) 9036 FORMAT('I,IMAPCO(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPMPLI(IHARG,IHARG2,NUMARG,IDEMPL,MAXMAR,IMAPLI, CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC CCCCC SUBROUTINE DPMPLI(IHARG,NUMARG,IDEMPL,MAXMAR,IMAPLI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN LINES = THE LINES TYPES C OF THE PATTERN WITHIN THE MARKERS. C THESE ARE LOCATED IN THE VECTOR IMAPLI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEMPL C --MAXMAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IMAPLI (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C UPDATED --AUGUST 1995. DASH2 BUG C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CCCCC AUGUST 1995. ADD FOLLOWING LINE CHARACTER*4 IHARG2 CHARACTER*4 IDEMPL CHARACTER*4 IMAPLI 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(*) CCCCC AUGUST 1995. ADD FOLLOWING LINE DIMENSION IHARG2(*) DIMENSION IMAPLI(*) 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='DPMP' ISUBN2='LI ' C NUMMAR=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 DPMPLI--') 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)MAXMAR,NUMMAR 53 FORMAT('MAXMAR,NUMMAR = ',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)IDEMPL 55 FORMAT('IDEMPL = ',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)IMAPLI(1) 70 FORMAT('IMAPLI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IMAPLI(I) 76 FORMAT('I,IMAPLI(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.2)GOTO9000 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 IF(NUMARG.EQ.5)GOTO1150 GOTO1160 C 1130 CONTINUE GOTO1200 C 1140 CONTINUE IF(IHARG(5).EQ.'ALL')IHOLD1=' ' IF(IHARG(5).EQ.'ALL')GOTO1300 GOTO1200 C 1150 CONTINUE CCCCC APRIL 1996. IHOLD TO IHOLD1 BELOW IF(IHARG(5).EQ.'ALL')THEN IHOLD1=IHARG(6) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF IF(IHARG(6).EQ.'ALL')THEN IHOLD1=IHARG(5) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF GOTO1200 C 1160 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE SINGLE SPECIFICATION CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.3)GOTO1210 GOTO1220 C 1210 CONTINUE NUMMAR=1 IMAPLI(1)=' ' GOTO1270 C 1220 CONTINUE NUMMAR=NUMARG-3 IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR DO1225I=1,NUMMAR J=I+3 IHOLD1=IHARG(J) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5' IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPL IMAPLI(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMMAR WRITE(ICOUT,1276)I,IMAPLI(I) 1276 FORMAT('THE LINE TYPE FOR MARKER PATTERN ',I6, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 3-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMMAR=MAXMAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPL DO1315I=1,NUMMAR IMAPLI(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)IMAPLI(I) 1316 FORMAT('THE LINE TYPE FOR ALL MARKER PATTERNS', 1' HAS JUST BEEN SET TO ',A4) 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 DPMPLI--') 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)MAXMAR,NUMMAR 9013 FORMAT('MAXMAR,NUMMAR = ',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)IDEMPL 9015 FORMAT('IDEMPL = ',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)IMAPLI(1) 9030 FORMAT('IMAPLI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IMAPLI(I) 9036 FORMAT('I,IMAPLI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPMPSP(IHARG,IARGT,ARG,NUMARG,PDEMPS,MAXMAR,PMAPSP, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE MARKER PATTERN SPACINGS = THE SPACINGS C BETWEEN THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE MARKERS. C THESE ARE LOCATED IN THE VECTOR PMAPSP(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEMPS C --MAXMAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PMAPSP (A FLOATING POINT VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) DIMENSION PMAPSP(*) 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='DPMP' ISUBN2='SP ' C NUMMAR=0 IHOLD1='-999' HOLD1=-999.0 HOLD2=-999.0 C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPMPSP--') 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)MAXMAR,NUMMAR 53 FORMAT('MAXMAR,NUMMAR = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)PDEMPS 55 FORMAT('PDEMPS = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)PMAPSP(1) 70 FORMAT('PMAPSP(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PMAPSP(I) 76 FORMAT('I,PMAPSP(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')HOLD1=PDEMPS IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE SINGLE SPECIFICATION CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMMAR=1 PMAPSP(1)=PDEMPS GOTO1270 C 1220 CONTINUE NUMMAR=NUMARG-2 IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR DO1225I=1,NUMMAR J=I+2 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEMPS IF(IHOLD1.EQ.'OFF')HOLD2=PDEMPS IF(IHOLD1.EQ.'AUTO')HOLD2=PDEMPS IF(IHOLD1.EQ.'DEFA')HOLD2=PDEMPS PMAPSP(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMMAR WRITE(ICOUT,1276)I,PMAPSP(I) 1276 FORMAT('THE SPACING BETWEEN (LINES WITHIN) PATTERN ',I6, 1' HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 3-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMMAR=MAXMAR HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEMPS IF(IHOLD1.EQ.'OFF')HOLD2=PDEMPS IF(IHOLD1.EQ.'AUTO')HOLD2=PDEMPS IF(IHOLD1.EQ.'DEFA')HOLD2=PDEMPS DO1315I=1,NUMMAR PMAPSP(I)=HOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)PMAPSP(I) 1316 FORMAT('THE SPACING BETWEEN (LINES WITHIN) ALL PATTERNS', 1' HAS JUST BEEN SET TO ',E15.7) 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 DPMPSP--') 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)MAXMAR,NUMMAR 9013 FORMAT('MAXMAR,NUMMAR = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PDEMPS 9015 FORMAT('PDEMPS = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)PMAPSP(1) 9030 FORMAT('PMAPSP(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PMAPSP(I) 9036 FORMAT('I,PMAPSP(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPMPTH(IHARG,IARGT,ARG,NUMARG,PDEMPT,MAXMAR,PMAPTH, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE MARKER PATTERN THICKNESSES = THE THICKNESSES C OF THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE MARKERS. C THESE ARE LOCATED IN THE VECTOR PMAPTH(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEMPT C --MAXMAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PMAPTH (A FLOATING POINT VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) DIMENSION PMAPTH(*) 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='DPMP' ISUBN2='TH ' C NUMMAR=0 IHOLD1='-999' HOLD1=-999.0 HOLD2=-999.0 C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPMPTH--') 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)MAXMAR,NUMMAR 53 FORMAT('MAXMAR,NUMMAR = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)PDEMPT 55 FORMAT('PDEMPT = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)PMAPTH(1) 70 FORMAT('PMAPTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PMAPTH(I) 76 FORMAT('I,PMAPTH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')HOLD1=PDEMPT IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')HOLD1=ARG(2) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE SINGLE SPECIFICATION CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMMAR=1 PMAPTH(1)=PDEMPT GOTO1270 C 1220 CONTINUE NUMMAR=NUMARG-2 IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR DO1225I=1,NUMMAR J=I+2 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEMPT IF(IHOLD1.EQ.'OFF')HOLD2=PDEMPT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEMPT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEMPT PMAPTH(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMMAR WRITE(ICOUT,1276)I,PMAPTH(I) 1276 FORMAT('THE THICKNESS OF (LINES WITHIN) PATTERN ',I6, 1' HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 3-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMMAR=MAXMAR HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEMPT IF(IHOLD1.EQ.'OFF')HOLD2=PDEMPT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEMPT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEMPT DO1315I=1,NUMMAR PMAPTH(I)=HOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)PMAPTH(I) 1316 FORMAT('THE THICKNESS OF (LINES WITHIN) ALL PATTERNS', 1' HAS JUST BEEN SET TO ',E15.7) 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 DPMPTH--') 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)MAXMAR,NUMMAR 9013 FORMAT('MAXMAR,NUMMAR = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PDEMPT 9015 FORMAT('PDEMPT = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)PMAPTH(1) 9030 FORMAT('PMAPTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PMAPTH(I) 9036 FORMAT('I,PMAPTH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPMPTY(IHARG,NUMARG,IDEMPT,MAXMAR,IMAPTY, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN TYPES = THE TYPES C OF THE PATTERN WITHIN THE MARKERS. C THESE ARE LOCATED IN THE VECTOR IMAPTY(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEMPT C --MAXMAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IMAPTY (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEMPT CHARACTER*4 IMAPTY 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 IMAPTY(*) 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='DPMP' ISUBN2='TY ' C NUMMAR=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 DPMPTY--') 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)MAXMAR,NUMMAR 53 FORMAT('MAXMAR,NUMMAR = ',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)IDEMPT 55 FORMAT('IDEMPT = ',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)IMAPTY(1) 70 FORMAT('IMAPTY(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IMAPTY(I) 76 FORMAT('I,IMAPTY(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE SINGLE SPECIFICATION CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMMAR=1 IMAPTY(1)=' ' GOTO1270 C 1220 CONTINUE NUMMAR=NUMARG-2 IF(NUMMAR.GT.MAXMAR)NUMMAR=MAXMAR DO1225I=1,NUMMAR J=I+2 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPT IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPT IMAPTY(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMMAR WRITE(ICOUT,1276)I,IMAPTY(I) 1276 FORMAT('THE TYPE FOR MARKER PATTERN ',I6, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 3-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMMAR=MAXMAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEMPT IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEMPT DO1315I=1,NUMMAR IMAPTY(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)IMAPTY(I) 1316 FORMAT('THE TYPE FOR ALL MARKER PATTERNS', 1' HAS JUST BEEN SET TO ',A4) 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 DPMPTY--') 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)MAXMAR,NUMMAR 9013 FORMAT('MAXMAR,NUMMAR = ',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)IDEMPT 9015 FORMAT('IDEMPT = ',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)IMAPTY(1) 9030 FORMAT('IMAPTY(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IMAPTY(I) 9036 FORMAT('I,IMAPTY(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPMRFP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A MEAN REPAIR FUNCTION PLOT. C THIS IS USED TO PLOT THE CUMULATIVE NUMBER OF C REPAIRS AGAINST TIME WHEN THERE ARE MULTIPLE C SYSTEMS. IN ADDITION, AN ESTIMATE OF M(T) C (DUE TO NELSON) BASED ON POOLED ESTIMATION IS C OVERLAID ON THE PLOT. C REFERENCE--TOBIAS AND TRINDADE (1995), "APPLIED C RELIABILITY", SECOND EDITION, CHAPMAN AND HALL, C PP. 311-315. C --NELSON (1995), "CONFIDENCE LIMITS FOR RECCURRENCE C DATA--APPLIED TO COST OR NUMBER OF PRODUCT C REPAIRS", TECHNOMETRICS, VOL. 37, NO. 2, C PP. 147-157. 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 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--2006/9 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASQ CHARACTER*4 IHRESP CHARACTER*4 IHRES2 CHARACTER*4 IHGROU CHARACTER*4 IHGRO2 CHARACTER*4 IHCENS CHARACTER*4 IHCEN2 C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) DIMENSION XCEN(MAXOBV) DIMENSION TEMP1(MAXOBV) DIMENSION TEMP2(MAXOBV) DIMENSION TEMP3(MAXOBV) DIMENSION TEMP4(MAXOBV) DIMENSION TEMP5(MAXOBV) C INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),X1(1)) EQUIVALENCE (GARBAG(IGARB3),XCEN(1)) EQUIVALENCE (GARBAG(IGARB4),TEMP1(1)) EQUIVALENCE (GARBAG(IGARB5),TEMP2(1)) EQUIVALENCE (GARBAG(IGARB6),TEMP3(1)) EQUIVALENCE (GARBAG(IGARB7),TEMP4(1)) EQUIVALENCE (GARBAG(IGARB8),TEMP5(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPMR' ISUBN2='FP ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=3 MINN2=2 C ICOLV2=0 C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPMRFP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)MAXCOL 54 FORMAT('MAXCOL = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C C C ********************************************* C ** TREAT THE MEAN REPAIR FUNCTION PLOT ** C ********************************************* C C ******************************************* C ** STEP 1-- ** C ** SEARCH FOR MEAN REPAIR FUNCTION PLOT ** C ******************************************* C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='MRFP' IF(NUMARG.GE.1.AND. 1 (ICOM.EQ.'MEAN' .OR. ICOM.EQ.'AVER').AND. 1 IHARG(1).EQ.'REPA'.AND.IHARG(2).EQ.'FUNC'.AND. 1 IHARG(3).EQ.'PLOT')THEN ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) IFOUND='YES' ELSE ICASPL=' ' IFOUND='NO' GOTO9000 ENDIF C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHRESP=IHARG(1) IHRES2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRESP,IHRES2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR=IVALUE(ILOCV) NRESP=IN(ILOCV) C C **************************************************** C ** STEP 12-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NRESP) FOR THE RESPONSE VARIABLE IS POSITIVE.** C **************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NRESP.LT.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN MEAN REPAIR FUNCTION PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212)IHRESP,IHRES2 1212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1 'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' FOR WHICH A MEAN REPAIR FUNCTION PLOT IS TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215)MINN2 1215 FORMAT(' BE GENERATED MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217) 1217 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1218)(IANS(I),I=1,MAX(80,IWIDTH)) 1218 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ******************************************** C ** STEP 13-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS WILL BE THE GROUP-ID VARIABLE) ** C ******************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHGROU=IHARG(2) IHGRO2=IHARG2(2) IHWUSE='V' MESSAG='NO' CALL CHECKN(IHGROU,IHGRO2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')THEN ICOLG=0 NGROUP=0 ELSE ICOLG=IVALUE(ILOCV) NGROUP=IN(ILOCV) ENDIF C C **************************************************** C ** STEP 14-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NGROUP) FOR THE GROUP-ID VARIABLE IS EQUAL ** C ** THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ** C ** VARIABLE. ** C **************************************************** C ISTEPN='14' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NGROUP.GT.0 .AND. (NGROUP.NE.NRESP))THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN MEAN REPAIR FUNCTION PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412)IHGROU,IHGRO2 1412 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1 'IN THE GROUP-ID VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) 1413 FORMAT(' IS NOT EQUAL TO THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414)IHRESP,IHRES2 1414 FORMAT(' IN THE RESPONSE VARIABLE ',A4,A4,'.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415)IHGROU,IHGROU2,NGROUP 1415 FORMAT(' THE NUMBBER OF OBSERVATIONS IN ',A4,A4, 1 ' = ',I10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415)IHRESP,IHRES2,NRESP CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1417) 1417 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1418)(IANS(I),I=1,MAX(80,IWIDTH)) 1418 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ******************************************** C ** STEP 15-- ** C ** CHECK THE VALIDITY OF ARGUMENT 3 ** C ** (THIS WILL BE THE CESNORING VARIABLE) ** C ******************************************** C ISTEPN='15' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHCENS=IHARG(3) IHCEN2=IHARG2(3) IHWUSE='V' MESSAG='NO' CALL CHECKN(IHCENS,IHCEN2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')THEN ICOLC=0 NCENS=0 ELSE ICOLC=IVALUE(ILOCV) NCENS=IN(ILOCV) ENDIF C C **************************************************** C ** STEP 16-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NCENS) FOR THE CENSORING VARIABLE IS EQUAL ** C ** THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ** C ** VARIABLE. ** C **************************************************** C ISTEPN='16' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NCENS.GT.0 .AND. (NCENS.NE.NRESP))THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611) 1611 FORMAT('***** ERROR IN MEAN REPAIR FUNCTION PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612)IHCENS,IHCEN2 1612 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1 'IN THE CENSORING VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613) 1613 FORMAT(' IS NOT EQUAL TO THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1614)IHRESP,IHRES2 1614 FORMAT(' IN THE RESPONSE VARIABLE ',A4,A4,'.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1615)IHCENS,IHCEN2,NCENS 1615 FORMAT(' THE NUMBBER OF OBSERVATIONS IN ',A4,A4, 1 ' = ',I10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1615)IHRESP,IHRES2,NRESP CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1617) 1617 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1618)(IANS(I),I=1,MAX(80,IWIDTH)) 1618 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ***************************************** C ** STEP 21-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2190 DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2120 2100 CONTINUE GOTO2190 2110 CONTINUE ICASQ='SUBS' ILOCQ=J1 GOTO2190 2120 CONTINUE ICASQ='FOR' ILOCQ=J1 GOTO2190 2190 CONTINUE C IF(ILOCQ.EQ.2)THEN NCENS=0 NGROUP=0 ENDIF IF(ILOCQ.EQ.3)THEN NCENS=0 ENDIF C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')THEN WRITE(ICOUT,2191)NUMARG,ILOCQ 2191 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C C *********************************************** C ** STEP 22-- ** C ** CHECK FOR A VALID NUMBER OF VARIABLES ** C ** (EITHER 1, 2, OR 3) ** C ** FOR A MEAN REPAIR FUNCTION PLOT). ** C *********************************************** C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.LT.1 .OR. NUMV2.GT.MAXV2)THEN C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2251) 2251 FORMAT('***** ERROR IN MEAN REPAIR FUNCTION PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2253) 2253 FORMAT(' THE NUMBER OF VARIABLES MUST BE 1, 2, OR 3;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2255) 2255 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2257)NUMV2 2257 FORMAT(' NUMBER OF VARIABLES WAS ',I10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2258) 2258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2259)(IANS(I),I=1,MAX(80,IWIDTH)) 2259 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C ENDIF C C ********************************************** C ** STEP 31-- ** C ** FORM THE VARIABLES Y1(.), X1(.), AND ** C ** XCEN(.) WHICH WILL CONTAIN THE DATA; ** C ** FORM THESE VARIABLES BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************** C ISTEPN='31' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASQ.EQ.'FULL')GOTO3110 IF(ICASQ.EQ.'SUBS')GOTO3120 IF(ICASQ.EQ.'FOR')GOTO3130 C 3110 CONTINUE DO3115I=1,NRESP ISUB(I)=1 3115 CONTINUE NQ=NRESP GOTO3150 C 3120 CONTINUE NIOLD=NRESP CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO3150 C 3130 CONTINUE NIOLD=NRESP CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR C 3150 CONTINUE C IF(NQ.LT.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3151) 3151 FORMAT('***** ERROR IN MEAN REPAIR FUNCTION PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3152) 3152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1 'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3153)IHRESP,IHRES2 3153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING ', 1 'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3154) 3154 FORMAT(' FOR WHICH A MEAN REPAIR FUNCTION PLOT IS TO ', 1 'BE FORMED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3156)MINN2 3156 FORMAT(' MUST BE ',I8,' OR LARGER; SUCH WAS NOT ', 1 'THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3158) 3158 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,3159)(IANS(I),I=1,MAX(80,IWIDTH)) 3159 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C J=0 IMAX=NRESP IF(NQ.LT.NRESP)IMAX=NQ DO3170I=1,IMAX C IF(ISUB(I).EQ.0)GOTO3170 J=J+1 IJ=MAXN*(ICOLR-1)+I C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')THEN WRITE(ICOUT,3166)I,J,IJ,ICOLR,MAXCOL,MAXN,V(IJ) 3166 FORMAT('I,J,IJ,ICOLR,MAXCOL,MAXN,V(IJ) = ',6I8,E15.7) CALL DPWRST('XXX','BUG ') ENDIF C IF(ICOLR.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLR.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)Y1(J)=TAGPLO(I) C IF(NGROUP.GT.0)THEN IJ=MAXN*(ICOLG-1)+I IF(ICOLG.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLG.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLG.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLG.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLG.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLG.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLG.EQ.MAXCP6)X1(J)=TAGPLO(I) ELSE X1(J)=0.0 ENDIF C IF(NCENS.GT.0)THEN IJ=MAXN*(ICOLC-1)+I IF(ICOLC.LE.MAXCOL)XCEN(J)=V(IJ) IF(ICOLC.EQ.MAXCP1)XCEN(J)=PRED(I) IF(ICOLC.EQ.MAXCP2)XCEN(J)=RES(I) IF(ICOLC.EQ.MAXCP3)XCEN(J)=YPLOT(I) IF(ICOLC.EQ.MAXCP4)XCEN(J)=XPLOT(I) IF(ICOLC.EQ.MAXCP5)XCEN(J)=X2PLOT(I) IF(ICOLC.EQ.MAXCP6)XCEN(J)=TAGPLO(I) ELSE XCEN(J)=0.0 ENDIF C 3170 CONTINUE NS=J C C ***************************************************** C ** STEP 41-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR ** C ** THE PLOT. ** C ** FORM THE CURVE DESIGNATION VARIABLED(.) . ** C ** THIS WILL BE ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV). ** C ***************************************************** C ISTEPN='41' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPMRF2(Y1,NS,X1,NGROUP,XCEN,NCENS,ICASPL,MAXN, 1TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 1Y,X,D,NPLOTP,NPLOTV, 1IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'MRFP')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPMRFP--') 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 = ', 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NPLOTP.GT.0)THEN 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 ENDIF ENDIF C RETURN END SUBROUTINE DPMRF2(Y1,N,X1,NGROUP,XCEN,NCENS,ICASPL,MAXN, 1XIDTEM,TEMP2,TEMP3,TEMP4,TEMP5, 1Y,X,D,NPLOTP,NPLOTV, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A MEAN REPAIR FUNCTION PLOT. C PLOT THE REPAIR TIMES FOR EACH GROUP, EACH GROUP C MAY HAVE A SINGLE CENSORING TIME. NELSON C DESCRIBES A METHOD FOR CREATING THE MEAN REPAIR C FUNCTION AND CORRESPONDING CONFIDENCE LIMITS. C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF C (UNSORTED) REPAIR/CENSORING TIMES. C --X1 = THE OPTIONAL SINGLE PRECISION VECTOR C GROUP-ID VALUES C --XCENS = THE OPTIONAL SINGLE PRECISION VECTOR C OF CENSOR VALUES (1 = REPAIR C TIME, 0 = CENSOR TIME). C NY = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR Y1. C NX = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X1. C NC = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR XCEN. C REFERENCE--TOBIAS AND TRINDADE (1995), "APPLIED C RELIABILITY", SECOND EDITION, CHAPMAN AND HALL, C PP. 311-315. C --NELSON (1995), "CONFIDENCE LIMITS FOR RECCURRENCE C DATA--APPLIED TO COST OR NUMBER OF PRODUCT C REPAIRS", TECHNOMETRICS, VOL. 37, NO. 2, C PP. 147-157. 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--2006/9 C ORIGINAL VERSION--SEPTEMBER 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION X1(*) DIMENSION XCEN(*) C DIMENSION XIDTEM(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION TEMP4(*) DIMENSION TEMP5(*) C DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPDU' ISUBN2='A2 ' C IERROR='NO' C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MRF2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPMRF2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR 52 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,NGROUP,NCENS,ICASPL,MAXN 53 FORMAT('N,NGROUP,NCENS,ICASPL,MAXN = ',3I10,2X,A4,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y1(I),X1(I),XCEN(I) 56 FORMAT('I, Y1(I),X1(I),XCEN(I) = ',I10,3G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE ENDIF C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.LT.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN MEAN REPAIR FUNCTION PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114)N 114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C HOLD=Y1(1) DO120I=1,N IF(Y1(I).NE.HOLD)GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN MEAN REPAIR FUNCTION PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122)HOLD 122 FORMAT(' ALL ELEMENTS IN RESPONSE VARIABLE ARE ', 1 'IDENTICALLY EQUAL TO ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 129 CONTINUE C C **************************************************** C ** STEP 12-- ** C ** COMPUTE COORDINATES FOR MEAN REPAIR FUNCTION ** C ** PLOT ** C **************************************************** C C C CASE 1: NO GROUP OR CENSORING VARIABLE C IF(NGROUP.EQ.0 .AND. NCENS.EQ.0)THEN CALL SORT(Y1,N,Y1) DO1000I=1,N Y(I)=REAL(I) X(I)=Y1(I) D(I)=1.0 1000 CONTINUE NPLOTP=N C C CASE 2: GROUP VARIABLE, BUT NO CENSORING VARIABLE C ELSEIF(NCENS.EQ.0)THEN C C STEP 1: DETERMINE UNIQUE GROUPS C CALL SORTC(Y1,X1,N,TEMP2,TEMP3) DO1010I=1,N Y1(I)=TEMP2(I) X1(I)=TEMP3(I) 1010 CONTINUE C NUMSET=0 DO1051I=1,N IF(NUMSET.EQ.0)GOTO1053 DO1052J=1,NUMSET IF(X1(I).EQ.XIDTEM(J))GOTO1051 1052 CONTINUE 1053 CONTINUE NUMSET=NUMSET+1 XIDTEM(NUMSET)=X1(I) 1051 CONTINUE CALL SORT(XIDTEM,NUMSET,XIDTEM) J=0 C C STEP 2: GENERATE MEAN TRACE C J=J+1 Y(J)=0.0 X(J)=0.0 D(J)=1.0 DO1060I=1,N J=J+1 Y(J)=REAL(I)/REAL(NUMSET) X(J)=Y1(I) D(J)=1.0 1060 CONTINUE C C STEP 3: GENERATE TRACES FOR EACH GROUP C ITRACE=1 DO1090ISET=1,NUMSET C K=0 DO1091I=1,N IF(X1(I).EQ.XIDTEM(ISET))THEN K=K+1 TEMP2(K)=Y1(I) ENDIF 1091 CONTINUE NI=K CALL SORT(TEMP2,NI,TEMP2) ITRACE=ITRACE+1 J=J+1 Y(J)=0.0 X(J)=0.0 D(J)=REAL(ITRACE) DO1096I=1,NI J=J+1 Y(J)=REAL(I) X(J)=TEMP2(I) D(J)=REAL(ITRACE) 1096 CONTINUE 1090 CONTINUE NPLOTP=J C C CASE 3: BOTH GROUP VARIABLE AND CENSORING VARIABLE C ELSE C C STEP 1: DETERMINE UNIQUE GROUPS C NUMSET=0 DO1111I=1,N IF(NUMSET.EQ.0)GOTO1113 DO1112J=1,NUMSET IF(X1(I).EQ.XIDTEM(J))GOTO1111 1112 CONTINUE 1113 CONTINUE NUMSET=NUMSET+1 XIDTEM(NUMSET)=X1(I) 1111 CONTINUE CALL SORT(XIDTEM,NUMSET,XIDTEM) C C STEP 2A: EXTRACT RESPONSE AND CENSORING DATA FOR EACH C GROUP C J=0 ITRACE=1 ISETMX=NUMSET DO1120ISET=1,NUMSET C K=0 DO1121I=1,N IF(X1(I).EQ.XIDTEM(ISET))THEN K=K+1 TEMP2(K)=Y1(I) TEMP3(K)=XCEN(I) ENDIF 1121 CONTINUE NI=K C C STEP 2B: PROCESS THE CENSORING VARIABLE. THERE CAN C BE AT MOST ONE CENSORING POINT FOR EACH C GROUP. C CALL SORTC(TEMP2,TEMP3,NI,TEMP4,TEMP5) DO1160I=1,NI TEMP2(I)=TEMP4(I) TEMP3(I)=TEMP5(I) 1160 CONTINUE AREP=TEMP3(1) ACEN=TEMP3(NI) IF(NI.LE.1)THEN NTEMPR=1 NTEMPC=0 ELSE IF(AREP.EQ.ACEN)THEN NTEMPR=NI NTEMPC=0 DO1170I=1,NI IF(TEMP3(I).NE.AREP)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1171) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1174)XIDTEM(ISET) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 1170 CONTINUE ELSE NTEMPR=NI-1 NTEMPC=1 DO1180I=1,NTEMPR IF(TEMP3(I).NE.AREP)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1171) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1174)XIDTEM(ISET) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 1180 CONTINUE ENDIF ENDIF 1171 FORMAT(' FOR EACH SYSTEM, THERE SHOULD BE AT MOST') 1172 FORMAT(' CENSORING TIME AND IT MUST BE THE MAXIMUM') 1173 FORMAT(' VALUE FOR THAT SYSTEM.') 1174 FORMAT(' SUCH WAS NOT THE CASE FOR SYSTEM ',G15.7) C C STEP 2C: TRACE 1 IS SIMPLY ALL OF THE REPAIR TIMES C (I.E., OMIT THE CENSORING TIME). THEN TRACES C 2 - NUMBER OF SYSTEMS + 1 ARE THE REPAIR PLUS C CENSORING TIMES FOR EACH SYSTEM. C CCCCC DO1191I=1,NTEMPR CCCCC J=J+1 CCCCC Y(J)=XIDTEM(ISET) CCCCC X(J)=TEMP2(I) CCCCC D(J)=1.0 C1191 CONTINUE C ITRACE=ITRACE+1 J=J+1 Y(J)=0.0 X(J)=0.0 D(J)=REAL(ITRACE) C DO1196I=1,NTEMPR J=J+1 Y(J)=REAL(I) X(J)=TEMP2(I) D(J)=REAL(ITRACE) 1196 CONTINUE IF(NTEMPC.GT.0)THEN J=J+1 Y(J)=REAL(NTEMPR) X(J)=TEMP2(NI) D(J)=REAL(ITRACE) ENDIF C 1120 CONTINUE C CALL SORTC(Y1,XCEN,N,TEMP4,TEMP5) J=J+1 Y(J)=0.0 X(J)=0.0 D(J)=1.0 NUMCEN=0 NUMREP=0 AMCF=0.0 DO1198I=1,N IF(TEMP5(I).LT.0.5)THEN NUMCEN=NUMCEN+1 ELSE IF(NUMSET-NUMCEN.GT.0)THEN AMCF=AMCF + 1.0/REAL(NUMSET-NUMCEN) ENDIF ENDIF J=J+1 Y(J)=AMCF X(J)=TEMP4(I) D(J)=1.0 1198 CONTINUE 1199 CONTINUE C NPLOTP=J ENDIF C NPLOTV=2 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'MRF2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPMRF2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3,ISUBRO,IERROR 9012 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,ICASPL,MAXN 9013 FORMAT('N,ICASPL,MAXN = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NPLOTP,NPLOTV 9021 FORMAT('NPLOTP,NPLOTV = ',2I8) CALL DPWRST('XXX','BUG ') DO9022I=1,NPLOTP WRITE(ICOUT,9023)I,Y(I),X(I),D(I) 9023 FORMAT('I,Y(I),X(I),D(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9022 CONTINUE ENDIF C RETURN END SUBROUTINE DPMUCC(IHARG,IHARG2,IARGT,ARG,NUMARG, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH, 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE MULTIPLOT CORNER COORDINATES C (LOWER LEFT AND UPPER RIGHT) C WHICH IN TURN WILL DEFINE THE SIZE AND SHAPE C OF THE TOTAL PLOT FRAME FOR MULTIPLOTS. C THE 2 PAIRS OF COORDINATES ARE CONTAINED IN THE C 4 VARIABLES PMXMIN,PMYMIN AND PMXMAX,PMYMAX C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG C OUTPUT ARGUMENTS--PMXMIN = X COOR. FOR LOWER LEFT CORNER C --PMXMAX = X COOR. FOR UPPER RIGHT CORNER C --PMYMIN = Y COOR. FOR LOWER LEFT CORNER C --PMYMAX = Y COOR. FOR UPPER RIGHT CORNER C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86/7 C ORIGINAL VERSION--MARCH 1986. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IANS CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHWORD CHARACTER*4 IHWOR2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION ARG(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IN(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IANS(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPMU' ISUBN2='CC ' C IFOUND='NO' IERROR='NO' C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE END OF DPMUCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IFOUND,IERROR 52 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)PMXMIN,PMXMAX,PMYMIN,PMYMAX 53 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** TREAT THE MULTIPLOT COORDINATES CASE ** C ************************************************** C IF(NUMARG.EQ.1)GOTO1150 GOTO1110 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(NUMARG.GE.2)GOTO1175 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPMUCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR MULTIPLOT COORDINATES ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE IT IS DESIRED TO POSITION ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' THE LOWER LEFT CORNER OF THE MULTIPLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' 10% ACROSS THE PAGE AND 20% UP THE PAGE, AND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' THE UPPER RIGHT CORNER OF THE MULTIPLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) 1129 FORMAT(' 90% ACROSS THE PAGE AND 80% UP THE PAGE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' THEN THE ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' MULTIPLOT COORDINATES 10 20 90 80') CALL DPWRST('XXX','BUG ') GOTO9000 C 1150 CONTINUE PMXMIN=15. PMYMIN=20. PMXMAX=85. PMYMAX=90. GOTO1180 C 1175 CONTINUE DO1176J=2,NUMARG IF(IARGT(J).EQ.'NUMB')GOTO1177 GOTO1178 1177 CONTINUE IF(J.EQ.2)PMXMIN=ARG(J) IF(J.EQ.3)PMYMIN=ARG(J) IF(J.EQ.4)PMXMAX=ARG(J) IF(J.EQ.5)PMYMAX=ARG(J) GOTO1176 1178 CONTINUE IHWORD=IHARG(J) IHWOR2=IHARG2(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(J.EQ.2)PMXMIN=VALUE(ILOC) IF(J.EQ.3)PMYMIN=VALUE(ILOC) IF(J.EQ.4)PMXMAX=VALUE(ILOC) IF(J.EQ.5)PMYMAX=VALUE(ILOC) 1176 CONTINUE GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1185) 1185 FORMAT('THE MULTIPLOT COORDINATES HAVE JUST BEEN SET ', 1'AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)PMXMIN,PMYMIN 1186 FORMAT(' (X,Y) FOR LOWER LEFT CORNER OF MULTIPLOT = ', 12E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1187)PMXMAX,PMYMAX 1187 FORMAT(' (X,Y) FOR UPPER RIGHT CORNER OF MULTIPLOT = ', 12E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPMUCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)PMXMIN,PMXMAX,PMYMIN,PMYMAX 9013 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPMULT(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH, 1IMPSW,IMPNR,IMPNC,IMPCO, CCCCC ADD FOLLOWING LINE AUGUST 1999. 1IMPARG, CCCCC ADD FOLLOWING LINE SEPTEMBER 1998. 1AMPSCH,AMPSCW, 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1IERASW, 1PWXMIN,PWXMAX,PWYMIN,PWYMAX, 1IERASV, 1PWXMIS,PWXMAS,PWYMIS,PWYMAS, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE MULTIPLOT PARAMETERS C WHICH ALLOW PROPER POSITIONING OF C SUCCEEDING SUB-PLOTS. C IMPSW = MULTIPLOT SWITCH (OFF OR ON) C IMPNR = NUMBER OF MULTIPLOT ROWS C IMPNC = NUMBER OF MULTIPLOT COLUMNS C IMPCO = CURRENT MULTIPLOT EXISTING SUBPLOT COUNT C IMPARG= NUMBER OF ARGUMENTS FOR MULTIPLOT C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (AN INTEGER VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG C OUTPUT ARGUMENTS/-IMPSW = ON-OFF MULTIPLOT SWITCH C --IMPNR = NUMBER OF ROWS OF SUBPLOTS C --IMPNC = NUMBER OF COLUMNS OF SUBPLOTS C --IMPCO = NUMBER OF ALREADY-EXISTING SUBPLOTS C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--MULTIPLOT IS USED IN DPGRAP C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--MARCH 1986. C UPDATED --MARCH 1988. ALLOW 4-ARGUMENT FORM C UPDATED --NOVEMBER 1991. MULTIPLOT FREEZE OR HOLD C UPDATED --NOVEMBER 1991. MULTIPLOT UNFREEZE OR UNHOLD C UPDATED --SEPTEMBER 1992. CHECK FOR ARGS = 0 C UPDATED --SEPTEMBER 1993. OMIT AUTO-ERASE C UPDATED --SEPTEMBER 1993. FIX FREEZE/UNFREEZE C UPDATED --OCTOBER 1993. FIX OVERWRITE C UPDATED --SEPTEMBER 1995. FIX NO-ARGUMENT BOMB C UPDATED --SEPTEMBER 1998. MULTIPLOT SCALE FACTOR C UPDATED --AUGUST 1999. RETURN NUMBER OF ARGUMENTS C (INITIAL PAGE ERASE SUPPRESSED C FOR 3 AND 4 ARGUMENT VERSION C OF MULTIPLOT) 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 C CHARACTER*4 IMPSW CHARACTER*4 IERASV CHARACTER*4 IERASW CCCCC CHARACTER*4 IX1TSW CCCCC CHARACTER*4 IX2TSW CCCCC CHARACTER*4 IY1TSW CCCCC CHARACTER*4 IY2TSW 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 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='DPMU' ISUBN2='LT ' C IFOUND='NO' IERROR='NO' C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPMULT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGP2,IFOUND,IERROR 53 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)NUMARG 68 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO70I=1,NUMARG WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7) CALL DPWRST('XXX','BUG ') 70 CONTINUE WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO 81 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX 82 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)IERASW 83 FORMAT('IERASW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)PWXMIN,PWXMAX,PWYMIN,PWYMAX 84 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,85)IERASV 85 FORMAT('IERASV = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86)PWXMIS,PWXMAS,PWYMIS,PWYMAS 86 FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************************* C ** TREAT THE MULTIPLOT CASE ** C ********************************************* C C ********************************************* C ** STEP 1-- C ** FOR ALL CASES, REGARDLESS OF WHETHER C ** MULTIPLOT IS BEING TURNED ON OR OFF, C ** REDEFINE PWXMIN ETC FROM THE SAVED VALUES C ** SO AS TO AVOID THE PROBLEM OF OVERWRITING C ** THE SAVED VALUES WHEN THE ANALYST C ** ENTERS MULTIPLE MULTIPLOT ON'S C ** WITHOUT AN INTERMEDIATE MULTIPLOT OFF . C ** THUS INITIALLY TREAT ALL CASES AS A C ** MULTIPLOT OFF . C ********************************************* C CCCCC THE FOLLOWING LINE WAS COMMENTED OUT NOVEMBER 1991 CCCCC IMPSW='OFF' C CCCCC THE FOLLOWING LINE WAS COMMENTED OUT SEPTEMBER 1993 CCCCC TO FIX PROBLEM OF MULTIPLOT AUTO-ERASE SEPTEMBER 1993 CCCCC EVEN IF PRE-ERASE HAD BEEN SET TO OFF SEPTEMBER 1993 CCCCC IERASW=IERASV C CCCCC THE FOLLOWING IF-CHECK WAS ADDED SEPTEMBER 1995 IF(NUMARG.GE.1)THEN CCCCC THE FOLLOWING 2 LINES WERE ENTERED SEPTEMBER 1993 IF(IHARG(NUMARG).EQ.'FREE')GOTO1090 IF(IHARG(NUMARG).EQ.'UNFR')GOTO1090 C PWXMIN=PWXMIS PWXMAX=PWXMAS PWYMIN=PWYMIS PWYMAX=PWYMAS C CCCCC THE FOLLOWING LINE WAS ENTERED SEPTEMBER 1993 1090 CONTINUE ENDIF CCCCC ADD FOLLOWING LINE AUGUST 1999. IMPARG=1 C C ********************************************* C ** STEP 2-- C ** BRANCH TO THE VARIOUS CASES C ********************************************* C IF(NUMARG.LE.0)GOTO1150 GOTO1110 C 1110 CONTINUE CCCCC ADD FOLLOWING LINE SEPTEMBER 1998. IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SCAL')GOTO1120 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160 CCCCC THE FOLLOWING 2 LINES WERE ADDED NOVEMBER 1991 IF(IHARG(NUMARG).EQ.'FREE')GOTO1140 IF(IHARG(NUMARG).EQ.'HOLD')GOTO1140 IF(IHARG(NUMARG).EQ.'UNFR')GOTO1145 IF(IHARG(NUMARG).EQ.'UNHO')GOTO1145 IF(NUMARG.LE.0)GOTO1150 GOTO1170 C 1120 CONTINUE CCCC ADD FOLLOWING SECTION SEPTEMBER 1998. CCCC MULTIPLOT SCALE FACTOR AMPSCH=1.0 AMPSCW=1.0 IF(IHARG(NUMARG).EQ.'SCAL')THEN AMPSCH=1.0 AMPSCW=1.0 ELSEIF(IHARG(NUMARG).EQ.'AUTO')THEN AMPSCH=1.0 AMPSCW=1.0 ELSEIF(IHARG(NUMARG).EQ.'DEFA')THEN AMPSCH=1.0 AMPSCW=1.0 ELSEIF(IHARG(NUMARG).EQ.'ON')THEN AMPSCH=1.0 AMPSCW=1.0 ELSEIF(IHARG(NUMARG).EQ.'OFF')THEN AMPSCH=1.0 AMPSCW=1.0 ELSEIF(IARGT(NUMARG).EQ.'NUMB'.AND.IARGT(NUMARG-1).EQ.'NUMB')THEN AMPSCW=ARG(NUMARG) AMPSCH=ARG(NUMARG-1) IF(AMPSCW.LE.0.0)AMPSCW=1.0 IF(AMPSCW.GE.100.0)AMPSCW=1.0 IF(AMPSCH.LE.0.0)AMPSCH=1.0 IF(AMPSCH.GE.100.0)AMPSCH=1.0 ELSEIF(IARGT(NUMARG).EQ.'NUMB')THEN AMPSCF=ARG(NUMARG) IF(AMPSCF.LE.0.0)AMPSCF=1.0 IF(AMPSCF.GE.100.0)AMPSCF=1.0 AMPSCH=AMPSCF AMPSCW=AMPSCF ELSE AMPSCH=1.0 AMPSCW=1.0 ENDIF IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211)AMPSCH 1211 FORMAT('MULTIPLOT HEIGHT SCALE FACTOR SET TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213)AMPSCW 1213 FORMAT('MULTIPLOT WIDTH SCALE FACTOR SET TO ',E15.7) CALL DPWRST('XXX','BUG ') GOTO9000 C CCCCC THE FOLLOWING SECTION (3 LINES) WAS ADDED NOVEMBER 1991 1140 CONTINUE IF(IMPSW.EQ.'ON')IMPSW='FREE' GOTO1180 C CCCCC THE FOLLOWING SECTION (6 LINES) WAS ADDED NOVEMBER 1991 1145 CONTINUE IF(IMPSW.EQ.'FREE')THEN IMPSW='ON' IMPCO=IMPCO+1 ENDIF GOTO1180 C 1150 CONTINUE CCCCC THE FOLLOWING LINE WAS ADDED OCTOBER 1993 CCCCC TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM OCTOBER 1993 IF(IMPSW.EQ.'OFF')IERASV=IERASW IMPSW='ON' IMPNR=2 IMPNC=2 IMPCO=1 CCCCC THE FOLLOWING LINE WAS COMMENTED OUT OCTOBER 1993 CCCCC TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM OCTOBER 1993 CCCCC IERASV=IERASW PWXMIS=PWXMIN PWXMAS=PWXMAX PWYMIS=PWYMIN PWYMAS=PWYMAX GOTO1180 C 1160 CONTINUE CCCCC THE FOLLOWING LINE WAS ADDED OCTOBER 1993 CCCCC TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM OCTOBER 1993 IF(IMPSW.EQ.'ON')IERASW=IERASV IMPSW='OFF' CCCCC THE FOLLOWING LINE WAS COMMENTED OUT OCTOBER 1993 CCCCC TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM OCTOBER 1993 CCCCC IERASW=IERASV PWXMIN=PWXMIS PWXMAX=PWXMAS PWYMIN=PWYMIS PWYMAX=PWYMAS GOTO1180 C 1170 CONTINUE CCCCC THE FOLLOWING 2 LINES WERE ADDED OCTOBER 1993 CCCCC TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM OCTOBER 1993 IF(IMPSW.EQ.'OFF')IERASV=IERASW IF(IMPSW.EQ.'ON')IERASW=IERASV IMPSW='ON' IMPCO=1 CCCCC THE FOLLOWING LINE WAS COMMENTED OUT OCTOBER 1993 CCCCC TO SOLVE THE MULTIPLOT OVERWRITING PROBLEM OCTOBER 1993 CCCCC IERASV=IERASW PWXMIS=PWXMIN PWXMAS=PWXMAX PWYMIS=PWYMIN PWYMAS=PWYMAX CCCCC RETURN NUMBER OF ARGUMENTS (IMPARG) AUGUST 1999 DO1171J=1,NUMARG IF(IARGT(J).EQ.'NUMB')GOTO1172 GOTO1173 1172 CONTINUE IF(J.EQ.1)IMPNR=IARG(J) IF(J.EQ.1)IMPARG=1 IF(J.EQ.2)IMPNC=IARG(J) IF(J.EQ.2)IMPARG=2 CCCCC IF(J.EQ.3)IMPCO=IARG(J) MARCH 1988 CCCCC THE FOLLOWING 3 LINES WERE ADJUSTED/ENTERED MARCH 1988 IF(J.EQ.3.AND.NUMARG.EQ.3)IMPCO=IARG(J) IF(J.EQ.3.AND.NUMARG.NE.3)IHOLD3=IARG(J) IF(J.EQ.3)IMPARG=3 IF(J.EQ.4)IMPCO=(IHOLD3-1)*IMPNC+IARG(J) IF(J.EQ.4)IMPARG=4 GOTO1171 1173 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.1)IMPNR=VALUE(ILOC)+0.5 IF(J.EQ.2)IMPNC=VALUE(ILOC)+0.5 CCCCC IF(J.EQ.3)IMPCO=VALUE(ILOC)+0.5 MARCH 1988 CCCCC THE FOLLOWING 4 LINES WERE ADJUSTED/ENTERED MARCH 1988 IF(J.EQ.3.AND.NUMARG.EQ.3)IMPCO=VALUE(ILOC)+0.5 IF(J.EQ.3.AND.NUMARG.NE.3)IHOLD3=VALUE(ILOC)+0.5 IF(J.EQ.4)IHOLD4=VALUE(ILOC)+0.5 IF(J.EQ.4)IMPCO=(IHOLD3-1)*IMPNC+IHOLD4 1171 CONTINUE GOTO1180 C 1180 CONTINUE IFOUND='YES' C CCCCC THE FOLLOWING SECTION WAS ADDE SEPTEMBER 1993 IF(IMPNR.LE.0.OR.IMPNC.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2011) 2011 FORMAT('***** ERROR IN SUBROUTINE DPMULT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2012) 2012 FORMAT(' NEGATIVE ARGUMENT ENCOUNTERED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2013)IMPNR 2013 FORMAT(' ARGUMENT 1 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2014)IMPNC 2014 FORMAT(' ARGUMENT 2 = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE MULTIPLOT SWITCH HAS JUST BEEN SET ') CALL DPWRST('XXX','BUG ') IF(IMPSW.EQ.'OFF')WRITE(ICOUT,1182) 1182 FORMAT('TO OFF') IF(IMPSW.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(IMPSW.EQ.'ON')WRITE(ICOUT,1183) 1183 FORMAT('TO ON WITH THE FOLLOWING SETTINGS--') IF(IMPSW.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IMPSW.EQ.'ON')WRITE(ICOUT,1184)IMPNR 1184 FORMAT(' NUMBER OF ROWS OF PLOTS = ',I8) IF(IMPSW.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IMPSW.EQ.'ON')WRITE(ICOUT,1185)IMPNC 1185 FORMAT(' NUMBER OF COLUMNS OF PLOTS = ',I8) IF(IMPSW.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IMPSW.EQ.'ON')WRITE(ICOUT,1186)IMPCO 1186 FORMAT(' NEXT PLOT TO BE GENERATED = ',I8) IF(IMPSW.EQ.'ON')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 DPMULT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGP2,IFOUND,IERROR 9013 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)NUMARG 9028 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9030I=1,NUMARG WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7) CALL DPWRST('XXX','BUG ') 9030 CONTINUE WRITE(ICOUT,9041)IMPSW,IMPNR,IMPNC,IMPCO 9041 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)PMXMIN,PMXMAX,PMYMIN,PMYMAX 9042 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)IERASW 9043 FORMAT('IERASW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)PWXMIN,PWXMAX,PWYMIN,PWYMAX 9044 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9045)IERASV 9045 FORMAT('IERASV = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9046)PWXMIS,PWXMAS,PWYMIS,PWYMAS 9046 FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPMXRL(IHARG,IARGT,IARG,NUMARG,IDEFRL,NUMRCM,MAXRCL, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE MAXIMUM RECORD LENGTH FOR READING DATA FILES. C NOTE THAT THIS CURRENTLY ONLY SPECIFIES THE LENGTH OF C DATA LINE READ. IT IS NOT CURRENTLY USED WHEN OPENING C THE FILE (ALTHOUGH THIS COULD BE ADDED AT A LATER DATE). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (AN INTEGER VECTOR) C --NUMARG C --IDEFRL (AN INTEGER DEFINING THE DEFAULT MAXIMUM C RECORD LENGTH) C --MAXRCL (AN INTEGER DEFINING THE MAXIMUM VALUE THAT C THE MAXIMUM RECORD LENGTH CAN BE SET TO) C OUTPUT ARGUMENTS--NUMRCM (AN INTEGER VARIABLE CONTAINING THE CURRENT C SETTING FOR THE MAXIMUM RECORD LENGTH FOR C DATA FILES) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003/2 C ORIGINAL VERSION--FEBRUARY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 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 IHOLD1=0 C C **************************************************** C ** TREAT THE CASE WHEN ** C ** THE MAXIMUM RECORD LENGTH IS TO BE CHANGED ** C **************************************************** C 1100 CONTINUE IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RECO'.AND.IHARG(2).EQ.'LENG') 1GOTO1110 GOTO9000 C 1110 CONTINUE IF(NUMARG.EQ.2)GOTO1120 IF(IHARG(NUMARG).EQ.'ON')GOTO1120 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 IF(IHARG(NUMARG).EQ.'?')GOTO8100 IF(NUMARG.GE.3.AND.IARGT(3).EQ.'NUMB')GOTO1130 GOTO9000 C 1120 CONTINUE IHOLD1=IDEFRL GOTO1180 C 1130 CONTINUE IHOLD1=IARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' NUMRCM=IHOLD1 C C CHECK AGAINST MAXIMUM RECORD LENGTH C IF(NUMRCM.LT.132)NUMRCM=132 IF(NUMRCM.GT.MAXRCL)NUMRCM=MAXRCL C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1185) 1185 FORMAT('THE MAXIMUM RECORD LENGTH (FOR READ AND SERIAL READ)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)NUMRCM 1186 FORMAT('HAVE JUST BEEN SET TO ',I8) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ******************************************** C ** STEP 81-- ** C ** TREAT THE ? CASE-- ** C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** C ******************************************** C 8100 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111)NUMRCM 8111 FORMAT('THE CURRENT MAXIMUM RECORD LENGTH IS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112)IDEFRL 8112 FORMAT('THE DEFAULT MAXIMUM RECORD LENGTH IS ',I8,I8) CALL DPWRST('XXX','BUG ') GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE DPNAME(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,IVALUE,VALUE,NUMNAM,MAXNAM, 1IVARLB, 1NUMCOL,MAXCOL,MAXN,IANS,IWIDTH,IBUGS2,IFOUND,IERROR) C C PURPOSE--TREAT THE NAME/RENAME CASE-- C NAMING OR RENAMING OF COLUMNS. C EXAMPLE--NAME 7 X C RENAME 7 X C RENAME PRESSURE Y C NOTE--THE RECOMMENDED VERB (FOR EASE OF REMEMBRANCE) IS RENAME. C THE SYNTAX IS RENAME EXISTING NAME NEW NAME C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION (IN DPLET)--DECEMBER 1977. C ORIGINAL VERSION AS A SEPARATE SUBROUTINE--MARCH 1978. C UPDATED --JUNE 1978. C UPDATED --NOVEMBER 1980. C UPDATED --JANUARY 1981. C UPDATED --NOVEMBER 1986. C UPDATED --JANUARY 2000. UPDATE VARIABLE LABEL 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*40 IVARLB CHARACTER*4 IANS CHARACTER*4 IBUGS2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 NEWCOL CHARACTER*4 IRIGHT CHARACTER*4 IRIGH2 CHARACTER*4 ILEFT CHARACTER*4 ILEFT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IN(*) DIMENSION IVSTAR(*) DIMENSION IVSTOP(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IVARLB(*) C DIMENSION IANS(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPNA' ISUBN2='ME ' C ICOLL=0 ILISTR=0 ILISTL=0 C IRIGHT='UNKN' IRIGH2='UNKN' ILEFT='UNKN' ILEFT2='UNKN' C C ********************************** C ** TREAT THE NAME/RENAME CASE ** C ********************************** C C ********************************** C ** STEP 1-- ** C ** INITIALIZE VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFOUND='YES' IERROR='NO' C NEWNAM='NO' NEWCOL='NO' C C ******************************************************* C ** STEP 2-- ** C ** CHECK THAT THERE ARE AT LEAST 2 ARGUMENTS. ** C ** WHEN HAVE MORE THAN 2 ARGUMENTS, ** C ** THEN THE FIRST AND THE LAST ARGUMENTS ** C ** ARE THE ONES WHICH ARE EXAMINED, ** C ** (WITH INTERMEDIATE INFORMATION IGNORED). ** C ** EXAMINE THE 2 ARGUMENTS ** C ** AND CHECK TO SEE THAT EXACTLY ONE IS A WORD ** C ** AND EXACTLY ONE IS A NUMBER. ** C ******************************************************* C ISTEPN='2' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C DO2000IPASS=1,NUMARG,2 IPASSP=IPASS+1 C IF(IARGT(IPASS).EQ.'WORD'.AND.IARGT(IPASSP).EQ.'NUMB')GOTO250 IF(IARGT(IPASS).EQ.'NUMB'.AND.IARGT(IPASSP).EQ.'WORD')GOTO250 IF(IARGT(IPASS).EQ.'WORD'.AND.IARGT(IPASSP).EQ.'WORD')GOTO1250 C WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,211) 211 FORMAT('***** ERROR IN DPNAME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,212) 212 FORMAT(' AT LEAST ONE OF THE ARGUMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,213) 213 FORMAT(' IN THE NAME COMMAND MUST BE A VARIABLE NAME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,214) 214 FORMAT(' IT IS NOT PERMITTED TO HAVE NUMBERS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,215) 215 FORMAT(' FOR BOTH ARGUMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,217) 217 FORMAT(' AN ERROR CONDITION EXISTS HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,218)IHARG(IPASS),IHARG2(IPASS),IARGT(IPASS) 218 FORMAT(' FIRST ARGUMENT = ',2A4,'--A ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,219)IHARG(2),IHARG2(2),IARGT(2) 219 FORMAT(' SECOND ARGUMENT = ',2A4,'--A ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,220) 220 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,221)(IANS(I),I=1,IWIDTH) 221 FORMAT(6X,80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 250 CONTINUE ILOCN=IPASS ILOCW=IPASSP IF(IARGT(IPASSP).EQ.'NUMB')ILOCN=IPASSP IF(IARGT(IPASS).EQ.'WORD')ILOCW=IPASS C ILEFT=IHARG(ILOCN) ILEFT2=IHARG2(ILOCN) IRIGHT=IHARG(ILOCW) IRIGH2=IHARG2(ILOCW) ICOLL=IARG(ILOCN) C C ******************************************************** C ** STEP 3-- ** C ** EXAMINE THE NAME ARGUMENT-- ** C ** IS THE NAME ** C ** ALREADY IN THE NAME LIST? ** C ** NOTE THAT ILISTR IS THE LINE IN THE TABLE ** C ** OF THE NAME. ** C ******************************************************** C ISTEPN='3' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMNAM.LE.0)GOTO310 DO300I=1,NUMNAM I2=I IF(IRIGHT.EQ.IHNAME(I).AND.IRIGH2.EQ.IHNAM2(I))GOTO380 300 CONTINUE 310 CONTINUE NEWNAM='YES' ILISTR=NUMNAM+1 IF(ILISTR.GT.MAXNAM)GOTO320 GOTO390 C 320 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('***** ERROR IN DPNAME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,322) 322 FORMAT(' THE NUMBER OF VARIABLE/PARAMETER/FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)ILISTR,MAXNAM 323 FORMAT(' NAMES (= ',I8,') HAS JUST EXCEEDED THE ', 1'ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,324) 324 FORMAT(' SUGGESTION--ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,326) 326 FORMAT(' AND THEN REDEFINE (REUSE) ONE OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,327) 327 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 380 CONTINUE ILISTR=I2 390 CONTINUE C C **************************************************************** C ** STEP 4-- C ** EXAMINE THE NUMBER ARGUMENT-- C ** IS IT A VALID COLUMN DESIGNATION (1 TO MAXCOL)? C ** IS IT AN OLD (PREVIOUSLY-USED) OR NEW COLUMN DESIGNATION? C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE C ** OF THE NUMBER ARGUMENT. C ** NOTE THAT ICOLL IS THE DATA COLUMN (1 TO MAXCOL) C ** FOR THE NUMBER ARGUMENT. C **************************************************************** C ISTEPN='4' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICOLL.LE.MAXCOL)GOTO419 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,405) 405 FORMAT('***** ERROR IN DPNAME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,406) 406 FORMAT(' THE COLUMN SPECIFICATION ON THE RIGHT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,407)MAXCOL 407 FORMAT(' SIDE SHOULD BE BETWEEN 1 AND ',I8, 1' (INCLUSIVE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,408) 408 FORMAT(' BUT WAS NOT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,409)ICOLL 409 FORMAT(' THE REFERENCED COLUMN WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411) 411 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,412)(IANS(I),I=1,IWIDTH) 412 FORMAT(6X,80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 419 CONTINUE C IF(NUMNAM.LE.0)GOTO432 DO430I=1,NUMNAM I2=I CCCCC IF(IN(I).EQ.ICOLL.AND.IUSE(I).EQ.'V')GOTO434 IF(IVALUE(I).EQ.ICOLL.AND.IUSE(I).EQ.'V')GOTO434 430 CONTINUE 432 CONTINUE NEWCOL='YES' ILISTL=NUMNAM+1 GOTO439 434 CONTINUE NEWCOL='NO' ILISTL=I2 GOTO439 439 CONTINUE C IF(ILISTL.LE.MAXNAM)GOTO459 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,451) 451 FORMAT('***** ERROR IN DPNAME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,452) 452 FORMAT(' THE NUMBER OF VARIABLE/PARAMETER/FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,453)ILISTR,MAXNAM 453 FORMAT(' NAMES (= ',I8,') HAS JUST EXCEEDED THE ', 1'ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,454) 454 FORMAT(' SUGGESTION--ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,455) 455 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,456) 456 FORMAT(' AND THEN REDEFINE (REUSE) ONE OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,457) 457 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 459 CONTINUE C C ************************************************* C ** STEP 5-- ** C ** MAKE THE ADJUSTMENTS TO THE INTERNAL LIST ** C ** ON THE BASIS OF THE LEFT SIDE ** C ** AND RIGHT SIDE INFORMATION. ** C ************************************************* C ISTEPN='5' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHNAME(ILISTR)=IRIGHT IHNAM2(ILISTR)=IRIGH2 IF(ILISTL.EQ.ILISTR)GOTO511 GOTO512 511 CONTINUE IUSE(ILISTR)='V' IVALUE(ILISTR)=ILISTR VALUE(ILISTR)=ILISTR GOTO519 512 CONTINUE IUSE(ILISTR)=IUSE(ILISTL) IVALUE(ILISTR)=IVALUE(ILISTL) VALUE(ILISTR)=VALUE(ILISTL) IN(ILISTR)=IN(ILISTL) IVARLB(ILISTR)=IVARLB(ILISTL) GOTO519 519 CONTINUE IVSTAR(ILISTR)=MAXN*(ICOLL-1)+1 IVSTOP(ILISTR)=MAXN*ICOLL-1 IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 IF(NEWCOL.EQ.'YES'.AND.ICOLL.GT.NUMCOL)NUMCOL=ICOLL C C ********************************************** C ** STEP 6-- ** C ** PRINT OUT A BRIEF MESSAGE ** C ** INDICATING THAT THE NAME EQUIVALENCING ** C ** HAS BEEN CARRIED OUT. ** C ********************************************** C ISTEPN='6' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFEEDB.EQ.'OFF')GOTO619 IF(IPASS.EQ.1)WRITE(ICOUT,999) IF(IPASS.EQ.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611)ICOLL,IRIGHT,IRIGH2 611 FORMAT('COLUMN ',I8,' HAS JUST BEEN RENAMED ',2A4) CALL DPWRST('XXX','BUG ') 619 CONTINUE GOTO2000 C C ******************************************************** C ** STEP 13-- ** C ** EXAMINE THE FIRST ARGUMENT-- ** C ** IS THE NAME ** C ** ALREADY IN THE NAME LIST? ** C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE ** C ** OF THE NAME. ** C ******************************************************** C 1250 CONTINUE ISTEPN='13' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILEFT=IHARG(IPASS) ILEFT2=IHARG2(IPASS) IRIGHT=IHARG(IPASSP) IRIGH2=IHARG2(IPASSP) C IF(NUMNAM.LE.0)GOTO1310 DO1300I=1,NUMNAM I2=I IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I))GOTO1380 1300 CONTINUE C 1310 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN DPNAME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' WHEN USING THE RENAME COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1313) 1313 FORMAT(' WITH BOTH ARGUMENTS BEING NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1314) 1314 FORMAT(' THE FIRST ARGUMENT MUST BE A NAME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT(' OF A PRE-EXISTING VARIABLE/PARAMETER/FUNCTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316) 1316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1317)ILEFT,ILEFT2 1317 FORMAT('THE ARGUMENT NAME IS ',A4,A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1380 CONTINUE ILISTL=I2 1390 CONTINUE C C **************************************************************** C ** STEP 14-- C ** EXAMINE THE SECOND ARGUMENT-- C ** IS THE NAME ** C ** ALREADY IN THE NAME LIST? ** C ** NOTE THAT ILISTR IS THE LINE IN THE TABLE ** C ** OF THE NAME. ** C **************************************************************** C ISTEPN='14' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' IF(NUMNAM.LE.0)GOTO1410 DO1400I=1,NUMNAM I2=I IF(IRIGHT.EQ.IHNAME(I).AND.IRIGH2.EQ.IHNAM2(I))GOTO1480 1400 CONTINUE C 1410 CONTINUE NEWNAM='YES' ILISTR=NUMNAM+1 IF(ILISTR.GT.MAXNAM)GOTO1420 GOTO1490 C 1420 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1421) 1421 FORMAT('***** ERROR IN DPNAME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1422) 1422 FORMAT(' THE NUMBER OF VARIABLE/PARAMETER/FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1423)ILISTR,MAXNAM 1423 FORMAT(' NAMES (= ',I8,') HAS JUST EXCEEDED THE ', 1'ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1424) 1424 FORMAT(' SUGGESTION--ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1425) 1425 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1426) 1426 FORMAT(' AND THEN REDEFINE (REUSE) ONE OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1427) 1427 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1480 CONTINUE ILISTR=I2 1490 CONTINUE C C ************************************************* C ** STEP 15-- ** C ** MAKE THE ADJUSTMENTS TO THE INTERNAL LIST ** C ** ON THE BASIS OF THE LEFT SIDE ** C ** AND RIGHT SIDE INFORMATION. ** C ************************************************* C ISTEPN='15' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHNAME(ILISTR)=IRIGHT IHNAM2(ILISTR)=IRIGH2 IUSE(ILISTR)=IUSE(ILISTL) IVALUE(ILISTR)=IVALUE(ILISTL) VALUE(ILISTR)=VALUE(ILISTL) IN(ILISTR)=IN(ILISTL) IVSTAR(ILISTR)=IVSTAR(ILISTL) IVSTOP(ILISTR)=IVSTOP(ILISTL) IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 C C ********************************************** C ** STEP 16-- ** C ** PRINT OUT A BRIEF MESSAGE ** C ** INDICATING THAT THE NAME EQUIVALENCING ** C ** HAS BEEN CARRIED OUT. ** C ********************************************** C ISTEPN='16' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFEEDB.EQ.'OFF')GOTO1619 IF(IPASS.EQ.1)WRITE(ICOUT,999) IF(IPASS.EQ.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611)ILEFT,ILEFT2,IRIGHT,IRIGH2 1611 FORMAT('NAME ',2A4,' HAS JUST BEEN RENAMED ',2A4,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612) 1612 FORMAT('NOTE THAT THE ORIGINAL NAME IS NOT DESTROYED;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613) 1613 FORMAT('THUS EITHER NAME MAY BE USED TO REFER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1614) 1614 FORMAT('TO THE ORIGINAL VARIABLE/PARAMETER/FUNCTION.') CALL DPWRST('XXX','BUG ') 1619 CONTINUE GOTO2000 2000 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGS2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNAME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILEFT,ILEFT2 9012 FORMAT('ILEFT,ILEFT2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IRIGHT,IRIGH2 9013 FORMAT('IRIGHT,IRIGH2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NEWCOL 9014 FORMAT('NEWCOL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)ICOLL,ILISTR,ILISTL 9016 FORMAT('ICOLL,ILISTR,ILISTL = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NUMNAM,NEWNAM 9021 FORMAT('NUMNAM,NEWNAM = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)ILISTL,ILISTR 9022 FORMAT('ILISTL,ILISTR = ',2I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMNAM WRITE(ICOUT,9026)I,IHNAME(I),IHNAM2(I) 9026 FORMAT('I,IHNAME(I),IHNAM2(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO9030I=1,NUMNAM WRITE(ICOUT,9031)I,IUSE(I),IVALUE(I),IN(I) 9031 FORMAT('I,IUSE(I),IVALUE(I),IN(I) = ',I8,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 9030 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPNAN2(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 LOGICAL NAND (= A NAND BOX) C WITH THE MIDDLE OF THE FLATTER SIDE C AT THE POINT (X1,Y1), C AND WITH THE MIDDLE OF THE POINTED SIDE C AT THE POINT (X2,Y2). C NOTE--THE HEIGHT OF THE BOX WILL BE EQUAL TO C THE ABOVE-DESCRIBED WIDTH OF THE BOX C (THAT IS, THE HEIGHT C OF THE BOX WILL BE EQUAL TO C THE WIDTH FROM (X1,Y1) TO (X2,Y2). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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.'NAN2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNAN2--') 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 LOGICAL NAND ** C ********************************* C C POWER=1.4 FACTOR=0.2 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) R=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 K=0 C X=R Y=-R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C DO5310I=271,451,10 PHI2=I-1 PHI2=PHI2*(2.0*3.1415926)/360.0 ABSCOS=ABS(COS(PHI2)) ABSSIN=ABS(SIN(PHI2)) X=R*(ABSCOS**POWER) Y=R*(ABSSIN**POWER) IF(SIN(PHI2).LT.0.0)Y=-Y X=X+R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 5310 CONTINUE C X=0 Y=R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C DO5320I=271,451,10 PHI2=I-1 PHI2=360.0-PHI2 PHI2=PHI2*(2.0*3.1415926)/360.0 X=FACTOR*R*COS(PHI2) Y=R*SIN(PHI2) CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 5320 CONTINUE C X=R Y=-R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 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 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 K=0 C X=-0.2*R Y=R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C DO5330I=271,451,10 PHI2=I-1 PHI2=360.0-PHI2 PHI2=PHI2*(2.0*3.1415926)/360.0 X=FACTOR*R*COS(PHI2) Y=R*SIN(PHI2) X=X-0.2*R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 5330 CONTINUE C NP=K C IPATT2='SOLI' IF(IREFSW(1).EQ.'ON') 1CALL DPFIRE(PX,PY,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) C 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.'NAN2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNAN2--') 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 DPNAND(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 LOGICAL NANDS C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE INPUT COORDINATES DEFINE THE BACK CENTER AND THE FRONT CENTER C OF THE LOGICAL NAND. 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 LOGICAL NAND 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 LOGICAL NAND 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 LOGICAL NAND 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 INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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.'NAND')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNAND--') 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='NAND' 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.2.AND. 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1GOTO1111 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1113 GOTO1130 C 1111 CONTINUE ITYPEO='ABSO' ILOCFN=1 GOTO1119 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='RELA' ILOCFN=2 GOTO1119 1119 CONTINUE C IF(ILOCFN.GT.NUMARG)GOTO1129 DO1120I=ILOCFN,NUMARG IF(IARGT(I).EQ.'NUMB')GOTO1120 GOTO1129 1120 CONTINUE IFOUND='YES' GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPNAND--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A LOGICAL NAND ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH THE MIDDLE OF THE FLATTER SIDE ', 1'AT THE POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' AND WITH THE POINTED END AT THE POINT 40 60') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' LOGICAL NAND 20 20 40 60 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' LOGICAL NAND 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 1159 CONTINUE C 1160 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X2=X1+X2 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 C 1170 CONTINUE CALL DPNAN2(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.'NAND')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNAND--') 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 DPNDER(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, 1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IERROR) C C PURPOSE--TREAT THE LET CASE FOR C FINDING THE NUMERICAL DERIVATIVE OF AN FUNCTION. C EXAMPLE--LET A = NUMERICAL DERIVATIVE X**3+2*X**2-4*X+5 FOR X = 1 C --LET X = NUMERICAL DERIVATIVE F1 FOR X = B C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/1 C ORIGINAL VERSION--JANUARY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IA CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IANGLU CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 IHOUT CHARACTER*4 IHOUT2 CHARACTER*4 IUOUT CHARACTER*4 IDUMV CHARACTER*4 IDUMV2 CHARACTER*4 IHPARN CHARACTER*4 IHPAR2 CHARACTER*4 IHL CHARACTER*4 IHL2 CHARACTER*4 IWD1 CHARACTER*4 IWD2 CHARACTER*4 IWD12 CHARACTER*4 IWD22 CHARACTER*4 ILAB CHARACTER*4 IKEY CHARACTER*4 IKEY2 CHARACTER*4 INCLUN CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEL CHARACTER*4 IFOUND CHARACTER*4 IFOUN1 CHARACTER*4 IFOUN2 CHARACTER*4 IERRO2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IOLD CHARACTER*4 IOLD2 CHARACTER*4 INEW CHARACTER*4 INEW2 C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IA(*) DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) C DIMENSION IDUMV(100) DIMENSION IDUMV2(100) C DIMENSION ILAB(10) DIMENSION IOLD(10) DIMENSION IOLD2(10) DIMENSION INEW(10) DIMENSION INEW2(10) C C-----MAKE DUMMY COMMON BLOCK FOR FUNCTION CALL----------- C PARAMETER (IDUMCH=1000) PARAMETER (IDUMC2=100) C CHARACTER*4 IBUGAZ CHARACTER*4 IZNAME CHARACTER*4 IZNAM2 CHARACTER*4 ZTYPEH CHARACTER*4 ZW21HO CHARACTER*4 ZW22HO CHARACTER*4 ZIPARN CHARACTER*4 ZPARN2 CHARACTER*4 ZMODEL CHARACTER*4 ZIDUMV CHARACTER*4 ZDUMV2 C DIMENSION ZMODEL(IDUMCH) DIMENSION ZTYPEH(IDUMCH) DIMENSION ZW21HO(IDUMCH) DIMENSION ZW22HO(IDUMCH) DIMENSION Z2HOLD(IDUMCH) C DIMENSION ZPARAM(IDUMC2) DIMENSION ZIPARN(IDUMC2) DIMENSION ZPARN2(IDUMC2) DIMENSION ZIDUMV(IDUMC2) DIMENSION ZDUMV2(IDUMC2) DIMENSION LOCDUZ(IDUMC2) C COMMON /DUMCMC/ IBUGAZ, ZTYPEH, ZW21HO, ZW22HO, ZIPARN, ZPARN2, & ZIDUMV, ZDUMV2, ZMODEL, IZNAME, IZNAM2, IZNDEX COMMON /DUMCMR/ ZPARAM, Z2HOLD, & NUMCHZ, NUMPVZ, NWHOLZ, NUMDVZ, LOCDUZ CCCCC EXTERNAL OPTFCN C CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1989 DIMENSION BJUNK(1) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C INCLUDE 'DPCOZZ.INC' DIMENSION XFULL(MAXOBV) DIMENSION YDER(MAXOBV) EQUIVALENCE (GARBAG(IGARB2),YDER(1)) 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='DPND' ISUBN2='ER ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IERROR='NO' C ILOCMX=0 NUMLIM=0 ILOC3=0 IP=0 IV=0 LOCDUM=0 C IHLEFT='UNKN' IHLEF2='UNKN' C C ********************************************** C ** TREAT THE NUMERICAL DERIVATIVE SUBCASE ** C ** OF THE LET COMMAND ** C ********************************************** C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDER')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNDER--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGCO,IBUGEV 53 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGQ 54 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' C MAXN2=MAXCHF MAXN3=MAXCHF C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL 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 ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE NAME NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C ****************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) DO2000I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))GOTO2100 2000 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2201) 2201 FORMAT('***** ERROR IN DPNDER--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2202) 2202 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, & FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2203)MAXNAM 2203 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2204) 2204 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2205) 2205 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2206) 2206 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2207) 2207 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C 2100 CONTINUE ILISTL=I2 C C ***************************************************** C ** STEP 3.1-- ** C ** EXTRACT THE RIGHT-SIDE FUNCTIONAL ** C ** EXPRESSION FROM THE INPUT COMMAND LINE ** C ** (STARTING WITH THE FIRST NON-BLANK LOCATION ** C ** AFTER THE ** C ** EQUAL SIGN AND ENDING WITH THE END OF THE LINE ** C ** OR WITH THE LAST NON-BLANK CHARACTER BEFORE ** C ** WRT . ** C ** PLACE THE FUNCTION IN IFUNC2(.) . ** C ***************************************************** C ISTEPN='3.1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWD1=IHARG(4) IWD12=IHARG2(4) IWD2='WRT ' IWD22=' ' CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1 IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IFOUND.EQ.'NO')THEN IWD1=IHARG(4) IWD12=IHARG2(4) IWD2='FOR ' IWD22=' ' CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1 IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'NO')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3101) 3101 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3102) 3102 FORMAT(' INVALID COMMAND FORM FOR INTEGRATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3103) 3103 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3104) 3104 FORMAT(' LET ... = NUMERICAL DERIVATIVE ... WRT ... ', 1 'FOR ... = ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3105) 3105 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH)) 3106 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF C C ****************************************************** C ** STEP 4-- ** C ** DETERMINE IF THE EXPRESSION HAS ANY FUNCTION ** C ** NAMES. INBEDDED. IF SO, REPLACE THE FUNCTION ** C ** NAMES BY EACH ** C ** FUNCTION'S DEFINITION. DO SO REPEATEDLY ** C ** UNTIL ALL FUNCTION REFERENCES HAVE BEEN ** C ** ANNIHILATED AND THE EXPRESSION IS LEFT ONLY WITH** C ** CONSTANTS, PARAMETERS, AND VARIABLES--NO ** C ** FUNCTIONS. PLACE THE ** C ** RESULTING FUNCTIONAL EXPRESSION INTO IFUNC3(.) ** C ****************************************************** C ISTEPN='4' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDER')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ILAB(1)='INPU' ILAB(2)='T FU' ILAB(3)='NCTI' ILAB(4)='ON ' ILAB(5)=' ' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) WRITE(ICOUT,5081)IDUMV(1),IDUMV2(1) 5081 FORMAT('DIFFERATION VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') C ENDIF C C ************************************* C ** STEP 5-- ** C ** EXTRACT QUALIFIER INFORMATION. ** C ************************************* C ISTEPN='5' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ************************************************* C ** STEP 5.1-- ** C ** DETERMINE THE DUMMY VARIABLE FOR THE ** C ** DIFFERENTIATION. ** C ************************************************* C ISTEPN='5.1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NRIGHT=-1 C IKEY='WRT ' IKEY2=' ' ISHIFT=1 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5119 IDUMV(1)=IHOUT IDUMV2(1)=IHOUT2 IZNAME=IDUMV(1) IZNAM2=IDUMV2(1) C C CHECK TO SEE IF DUMMY VARIABLE IS ALREADY DEFINED AS A C VARIABLE (USE THESE VALUES IF NO FOR CLAUSE SPECIFIED) C IHWUSE='V' MESSAG='NO' CALL CHECKN(IZNAME,IZNAM2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'NO')THEN ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) ENDIF C NUMDV=1 GOTO5190 5119 CONTINUE C IKEY='FOR ' IKEY2=' ' ISHIFT=1 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5129 IDUMV(1)=IHOUT IDUMV2(1)=IHOUT2 IZNAME=IDUMV(1) IZNAM2=IDUMV2(1) C C CHECK TO SEE IF DUMMY VARIABLE IS ALREADY DEFINED AS A C VARIABLE (USE THESE VALUES IF NO FOR CLAUSE SPECIFIED) C IHWUSE='V' MESSAG='NO' CALL CHECKN(IZNAME,IZNAM2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'NO')THEN ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) ENDIF C NUMDV=1 GOTO5190 5129 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5181) 5181 FORMAT('***** ERROR IN NUMERICAL DIFFERENTIATION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5182) 5182 FORMAT(' INVALID COMMAND FORM FOR DIFFERENTIATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5183) 5183 FORMAT(' NO VARIABLE OF DIFFERENTIATION DEFINED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5185) 5185 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5186) 5186 FORMAT(' LET ... = NUMERICAL DERIVATIVE ... WRT ... ', 1'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5187) 5187 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,5189)(IANS(I),I=1,MIN(100,IWIDTH)) 5189 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 5190 CONTINUE C C ************************************************** C ** STEP 5.2-- ** C ** DETERMINE THE POINT AT WHICH TO COMPUTE THE ** C ** DERIVATIVE. ** C ************************************************** C ISTEPN='5.2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMLIM=0 C IKEY='FOR ' IKEY2=' ' ISHIFT=3 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.AND.IFOUN2.EQ.'NO')THEN IF(NRIGHT.GT.0)THEN DO5215J=1,NRIGHT IJ=MAXN*(ICOLR-1)+J IF(ICOLR.LE.MAXCOL)XFULL(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)XFULL(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)XFULL(J)=RES(I) IF(ICOLR.EQ.MAXCP3)XFULL(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)XFULL(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)XFULL(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)XFULL(J)=TAGPLO(I) 5215 CONTINUE ELSE GOTO5219 ENDIF ENDIF X0=VOUT NUMLIM=NUMLIM+1 ILOCMX=ILOC2 5219 CONTINUE C CCCCC CHECK TO SEE IF DIFFERENTIATION VARIABLE HAS BEEN PREVIOUSLY CCCCC DEFINED. C IF(NUMLIM.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5281) 5281 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5282) 5282 FORMAT(' INVALID COMMAND FORM FOR DIFFERENTIATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5283) 5283 FORMAT(' THE POINT AT WHICH TO COMPUTE THE NUMERICAL ', 1 'DERIVATIVE IS NOT DEFINED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5286) 5286 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5287) 5287 FORMAT(' LET ... = NUMERICAL DERIVATIVE ... WRT ... ', 1 'FOR ... = ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5288) 5288 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,5289)(IANS(I),I=1,MIN(100,IWIDTH)) 5289 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ********************************************** C ** STEP 6.3-- ** C ** SCAN THE QUALIFIERS FOR VARIABLE, ** C ** PARAMETER, FUNCTION, AND VALUE CHANGES ** C ** IN THE FUNCTION. ** C ********************************************** C ISTEPN='6.3' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NCHANG=0 DO6300IFORI=1,10 C IKEY='FOR ' IKEY2=' ' ISHIFT=1 IF(IFORI.EQ.1)ILOCA=ILOCMX IF(IFORI.NE.1)ILOCA=ILOC3 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1 IHARG,IHARG2,NUMARG, 1 INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1 IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1 INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO'.AND.IERROR.EQ.'NO')GOTO6350 C ILOC3=ILOC2+2 IF(IERROR.EQ.'YES' .OR. ILOC3.GT.NUMARG)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6301) 6301 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6302) 6302 FORMAT(' INVALID COMMAND FORM FOR DIFFERENTATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6303) 6303 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6304) 6304 FORMAT(' LET FUNCTION ... = NUMERICAL DERIVATIVE ... ', 1 'WRT ... FOR ... = ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6305) 6305 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,6306)(IANS(I),I=1,MIN(100,IWIDTH)) 6306 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF NCHANG=NCHANG+1 IOLD(NCHANG)=IHARG(ILOC2) IOLD2(NCHANG)=IHARG2(ILOC2) INEW(NCHANG)=IHARG(ILOC3) INEW2(NCHANG)=IHARG2(ILOC3) C 6300 CONTINUE 6350 CONTINUE C 6390 CONTINUE C C ********************************************** C ** STEP 6.4-- ** C ** CARRY OUT THE VARIABLE, ** C ** PARAMETER, AND FUNCTION CHANGES ** C ** AND THEN PRINT OUT A BRIEF MESSAGE ** C ** INDICATING THAT THE CHANGES ** C ** HAVE BEEN MADE. ** C ********************************************** C ISTEPN='6.4' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO6490 IF(IFEEDB.EQ.'OFF')GOTO6490 IF(NCHANG.LE.0)GOTO6490 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ILAB(1)='PRE ' ILAB(2)='-CHA' ILAB(3)='NGE ' ILAB(4)='FUNC' ILAB(5)='TION' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG,IFUNC3,N3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C ILAB(1)='POST' ILAB(2)='-CHA' ILAB(3)='NGE ' ILAB(4)='FUNC' ILAB(5)='TION' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C 6490 CONTINUE C C ******************************************************* C ** STEP 6.7-- ** C ** MAKE A NON-CALCULATING PASS AT THE FUNCTION ** C ** SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES.* C ******************************************************* C ISTEPN='6.8' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C IPASS=1 CALL COMPIM(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK, 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IZNDEX=1 DO6493I=1,NUMPV IF(IPARN(I).EQ.IZNAME .AND. IPARN2(I).EQ.IZNAM2)THEN IZNDEX=I GOTO6499 ENDIF 6493 CONTINUE 6499 CONTINUE C C *********************************************** C ** STEP 7-- ** C ** CHECK THAT ALL PARAMETERS ** C ** IN THE FUNCTION ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.). ** C *********************************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IP=0 IV=0 IF(NUMPV.LE.0)GOTO7650 DO7600J=1,NUMPV IHPARN=IPARN(J) IHPAR2=IPARN2(J) IF(IHPARN.EQ.IDUMV(1).AND.IHPAR2.EQ.IDUMV2(1))THEN IV=IV+1 LOCDUM=J GOTO7600 ENDIF IHWUSE='P' MESSAG='YES' CALL CHECKN(IHPARN,IHPAR2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'YES')THEN C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7611) 7611 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7612) 7612 FORMAT(' A PARAMETER/FUNCTION HAS BEEN ENCOUNTERED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7613) 7613 FORMAT(' IN THE FUNCTION TO BE DIFFERENTIATED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7614) 7614 FORMAT(' WHICH HAS NOT YET BEEN DEFINED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7615) 7615 FORMAT(' THE UNKNOWN PARAMETER/FUNCTION = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7616) 7616 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,7617)(IANS(I),I=1,MIN(100,IWIDTH)) 7617 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IP=IP+1 PARAM(J)=VALUE(ILOCP) 7600 CONTINUE 7650 CONTINUE C C ****************************** C ** STEP 8-- ** C ** COMPUTE THE DERIVATIVE ** C ****************************** C ISTEPN='8' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDER')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7711) 7711 FORMAT('***** FROM DPNDER, IMMEDIATELY BEFORE CALLING ', 1 'DPNDE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7712)N3,NUMPV 7712 FORMAT('N3,NUMPV = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7713)NUMDV,X0,XDER,NRIGHT 7713 FORMAT('NUMDV,X0,XDER,NRIGHT = ',I8,2E15.7,I8) CALL DPWRST('XXX','BUG ') DO7714I=1,NUMDV WRITE(ICOUT,7715)I,IDUMV(I),IDUMV2(I) 7715 FORMAT('I,IDUMV(I),IDUMV2(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 7714 CONTINUE WRITE(ICOUT,7716)IBUGA3,IBUGCO,IBUGEV 7716 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C COPY OVER DUMMY COMMON BLOCKS FOR DUMFUN ROUTINE C DO7805KK=1,MAXF3 ZMODEL(KK)=IFUNC3(KK) 7805 CONTINUE DO7810KK=1,IDUMCH ZTYPEH(KK)=ITYPEH(KK) ZW21HO(KK)=IW21HO(KK) ZW22HO(KK)=IW22HO(KK) Z2HOLD(KK)=W2HOLD(KK) 7810 CONTINUE DO7820KK=1,IDUMC2 ZPARAM(KK)=PARAM(KK) ZIPARN(KK)=IPARN(KK) ZPARN2(KK)=IPARN2(KK) ZIDUMV(KK)=IDUMV(KK) ZDUMV2(KK)=IDUMV2(KK) 7820 CONTINUE NUMCHZ=N3 NUMPVZ=NUMPV NWHOLZ=NWHOLD NUMDVZ=NUMDV IBUGAZ=IBUGA3 C IHP='XMIN' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN XMIN=CPUMIN ELSE XMIN=VALUE(ILOCP) ENDIF C IHP='XMAX' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN XMAX=CPUMAX ELSE XMAX=VALUE(ILOCP) ENDIF C IHP='XERR' IHP2='OR ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN XERROR=CPUMIN ELSE XERROR=VALUE(ILOCP) ENDIF C DO7889I=1,MAXOBV YDER(I)=0.0 7889 CONTINUE C CALL DPNDE2(X0,XDER,XMIN,XMAX,XERROR, 1XFULL,YDER,NRIGHT, 1IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR) C C ***************************************************** C ** STEP 9-- ** C ** ENTER THE DERIVATIVE VALUE INTO THE DATAPLOT ** C ** HOUSEKEEPING ARRAY ** C ***************************************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NDER') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHL=IHLEFT IHL2=IHLEF2 ICASEL='P' IF(NRIGHT.GT.0)THEN ICASEL='V' XDER=YDER(1) IXDER=XDER+0.5 CALL DPINVP(IHL,IHL2,ICASEL,YDER,NRIGHT,XDER,IXDER, 1 ISUBN1,ISUBN2,IBUGA3,IERROR) ELSE ICASEL='P' IXDER=XDER+0.5 BJUNK(1)=AJUNK NJUNK=1 CALL DPINVP(IHL,IHL2,ICASEL,BJUNK,NJUNK,XDER,IXDER, 1 ISUBN1,ISUBN2,IBUGA3,IERROR) ENDIF C C **************** C ** STEP 90-- ** C ** EXIT ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDER')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNDER--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3 9012 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGCO,IBUGEV 9013 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IBUGQ 9014 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMNAM WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I), 1 IVSTAR(I),IVSTOP(I) 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=', 1 I8,2X,A4,A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)NUMCHF,MAXCHF,IWIDTH,N2 9017 FORMAT('NUMCHF,MAXCHF,IWIDTH,N2 = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)(IFUNC(I),I=1,IWIDTH) 9018 FORMAT('IFUNC(.) = ',115A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)(IFUNC2(I),I=1,N2) 9019 FORMAT('IFUNC2(.) = ',115A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)N3 9020 FORMAT('N3 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)(IFUNC3(I),I=1,N3) 9021 FORMAT('IFUNC3(.) = ',115A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)NUMPV 9022 FORMAT('NUMPV = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)IP,IV,IDUMV(1),IDUMV2(1),LOCDUM 9023 FORMAT('IP,IV,IDUMV(1),IDUMV2(1),LOCDUM = ',I8,I8,2X,A4,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)IHLEFT,IHLEF2 9024 FORMAT('IHLEFT,IHLEF2 = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)ICASEL,IFOUND,IERROR 9025 FORMAT('ICASEL,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)XMIN,XMAX,XDER 9026 FORMAT('XMIN,XMAX,XDER = ',3E15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPNDE2(X0,XDER,XMIN,XMAX,XERROR, 1XFULL,YDER,N, 1IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR) C C PURPOSE--COMPUTE THE DERIVATIVE OF A FUNCTION AT THE POINT X0. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/1 C ORIGINAL VERSION--JANUARY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C REAL XFULL(*) REAL YDER(*) C REAL DUMFUN EXTERNAL DUMFUN 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='DPND' ISUBN2='E2 ' C IORD=1 IF(XERROR.EQ.CPUMIN)THEN EPS=0.0001 ELSE EPS=XERROR ENDIF ACCUR=0.0 IFAIL=0 C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDE2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNDE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,IBUGCO,IBUGEV 52 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)X0,EPS 62 FORMAT('X0,EPS = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)N 64 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C C *************************************************** C ** STEP 1-- ** C ** CALL DIFF ROUTINE (FROM CMLIB) TO COMPUTE ** C ** THE DERIVATIVE. ** C *************************************************** C IF(N.LE.0)THEN CALL DIFF(IORD,X0,XMIN,XMAX,DUMFUN,EPS,ACCUR,XDER,ERROR,IFAIL) C IF(IFAIL.EQ.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,301) 301 FORMAT('***** WARNING IN NUMERICAL DERIVATIVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,303) 303 FORMAT(' THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,305) 305 FORMAT(' REQUESTED ERROR, BUT THE MOST ACCURATE RESULT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,307) 307 FORMAT(' POSSIBLE HAS BEEN RETURNED.') CALL DPWRST('XXX','BUG ') ELSEIF(IFAIL.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' ERROR IN THE INPUT TO THE DIFF ROUTINE.') CALL DPWRST('XXX','BUG ') XDER=0.0 ERROR=0.0 IERROR='YES' GOTO9000 ELSEIF(IFAIL.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323) 323 FORMAT(' THE INTERVAL FOR DIFFERENTIATION, (',G15.7, 1 ',',G15.7,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' IS TOO SMALL.') CALL DPWRST('XXX','BUG ') XDER=0.0 ERROR=0.0 IERROR='YES' GOTO9000 ENDIF ELSE DO400I=1,N X0=XFULL(I) CALL DIFF(IORD,X0,XMIN,XMAX,DUMFUN,EPS,ACCUR,XDER, 1 ERROR,IFAIL) YDER(I)=XDER C IF(IFAIL.EQ.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401)X0 401 FORMAT('***** WARNING IN NUMERICAL DERIVATIVE AT ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,403) 403 FORMAT(' THE ESTIMATED ERROR IN THE RESULT EXCEEDS ', 1 'THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,405) 405 FORMAT(' REQUESTED ERROR, BUT THE MOST ACCURATE ', 1 'RESULT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,407) 407 FORMAT(' POSSIBLE HAS BEEN RETURNED.') CALL DPWRST('XXX','BUG ') ELSEIF(IFAIL.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411)X0 411 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE AT ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413) 413 FORMAT(' ERROR IN THE INPUT TO THE DIFF ROUTINE.') CALL DPWRST('XXX','BUG ') ELSEIF(IFAIL.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,421)X0 421 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE AT ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,423) 423 FORMAT(' THE INTERVAL FOR DIFFERENTIATION, (',G15.7, 1 ',',G15.7,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,425) 425 FORMAT(' IS TOO SMALL.') CALL DPWRST('XXX','BUG ') ENDIF 400 CONTINUE ENDIF C IF(IFEEDB.EQ.'ON' .AND. N.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3511)X0,XDER 3511 FORMAT('AT X0 = ',G15.7,' THE DERIVATIVE VALUE = ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3513)ERROR 3513 FORMAT('(WITH ESTIMATED ERROR = ',G15.7,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDE2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNDE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ERROR,XMIN,XMAX,X0,XDER 9012 FORMAT('ERROR,XMIN,XMAX,X0,XDER = ',5G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IERROR 9014 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPNEGA(IHARG,NUMARG,INEGSW,IFOUND,IERROR) C C PURPOSE--DEFINE THE NEGATIVE SWITCH INEGSW C (WHICH IS USEFUL, FOR EXAMPLE, IN GENERATING C HANGING HISTOGRAMS). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--INEGSW ('ON' OR 'OFF') C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1978. C UPDATED --SEPTEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 INEGSW 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 IF(NUMARG.GE.1)GOTO1110 GOTO1199 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 INEGSW='ON' GOTO1180 C 1160 CONTINUE INEGSW='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)INEGSW 1181 FORMAT('THE NEGATIVE SWITCH HAS JUST BEEN TURNED ', 1A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPNEWS(IBUGS2,ISUBRO,IFOUND,IERROR) C C PURPOSE--DISPLAY DATAPLOT NEWS C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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--OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1985. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGS2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST 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 ISTRIN 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='DPNE' ISUBN2='WS ' C IFOUND='YES' IERROR='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'NEWS')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNEWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR 53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,54)IWIDTH CCC54 FORMAT('IWIDTH = ',I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)INEWNU 61 FORMAT('INEWNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)INEWNA 62 FORMAT('INEWNA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)INEWST 63 FORMAT('INEWST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)INEWFO 64 FORMAT('INEWFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)INEWAC 65 FORMAT('INEWAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)INEWFO 66 FORMAT('INEWFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)INEWCS 67 FORMAT('INEWCS = ',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.'NEWS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNIT=INEWNU IFILE=INEWNA ISTAT=INEWST IFORM=INEWFO IACCES=INEWAC IPROT=INEWPR ICURST=INEWCS C ISUBN0='NEWS' IERRFI='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'NEWS')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 NEWS FILE EXISTS ** C **************************************** C ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS') 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 DPNEWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE DESIRED NEWS') 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 NEWS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' IS NOT AVAILABLE AT THIS INSTALLATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)ISTAT,INEWST 1217 FORMAT('ISTAT,INEWST = ',A12,2X,A12) CALL DPWRST('XXX','BUG ') GOTO9000 1290 CONTINUE C C ********************* C ** STEP 31-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='31' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IREWIN='ON' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 C C ****************************** C ** STEP 41-- ** C ** READ THE FILE. ** C ** WRITE OUT THE NEWS. ** C ****************************** C ISTEPN='41' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'MESS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ANUMLI=0.0 READ(IOUNIT,4111,END=4190)ANUMLI 4111 FORMAT(F10.0) NUMLIN=ANUMLI+0.5 C IF(NUMLIN.LE.0)GOTO4190 DO4120I=1,NUMLIN READ(IOUNIT,4121,END=4190)(ISTRIN(J:J),J=1,80) 4121 FORMAT(80A1) CALL DPDB80(ISTRIN,JMAX,IBUGS2,ISUBRO,IERROR) IF(JMAX.GE.1)WRITE(ICOUT,4122)(ISTRIN(J:J),J=1,JMAX) 4122 FORMAT(5X,80A1) IF(JMAX.GE.1)CALL DPWRST('XXX','BUG ') IF(JMAX.LE.0)WRITE(ICOUT,999) IF(JMAX.LE.0)CALL DPWRST('XXX','BUG ') 4120 CONTINUE 4190 CONTINUE C C *********************** C ** STEP 51-- ** C ** CLOSE THE FILE. ** C *********************** C ISTEPN='51' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'NEWS') 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 C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'NEWS')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNEWS--') 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 DPNORM(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1IX1TSC,IX2TSC,IY1TSC,IY2TSC, 1IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--FORM A NORMAL PLOT C (= A NORMAL PROBABILITY PLOT C BUT WITH DATA ON HORIZONTAL AXIS C AND WITH NEAT PROBABILITY VALUES C ON THE VERTICAL AXIS). C EXAMPLE--NORMAL PLOT Y C NORMAL PLOT Y TAG C NOTE--NORMALLY THIS COMMAND HAS 1 ARGUMENT. C ARGUMENT 1 IS THE RESPONSE VARIABLE C IF THE NORMAL PLOT COMMAND HAS ONLY C 1 ARGUMENT, THEN IT IS ASSUMED THAT ALL C OF THE DATA IS TO BE INCLUDED C (THAT IS, NO CENSORING). C NOTE--SOMETIMES THIS COMMAND HAS 2 ARGUMENTS-- C ARGUMENT 1 IS THE RESPONSE VARIABLE C ARGUMENT 2 IS THE CENSOR-TAG VARIABLE C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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--90/6 C ORIGINAL VERSION--MAY 1990. C UPDATED --APRIL 1992. DEFINE CUTOFF (ALAN) C UPDATED --APRIL 1992. SPLIT 'SIGMA' C UPDATED --APRIL 1992. COMMENT OUT IHRI3./4. C UPDATED --MAY 1995. ADD LINE TO EQUIVALENCE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 C CHARACTER*4 IX1TSC CHARACTER*4 IX2TSC CHARACTER*4 IY1TSC CHARACTER*4 IY2TSC C CHARACTER*4 IX1TSV CHARACTER*4 IX2TSV CHARACTER*4 IY1TSV CHARACTER*4 IY2TSV C CHARACTER*4 IANGLU CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASEQ C CHARACTER*4 IHRI11 CHARACTER*4 IHRI12 CHARACTER*4 IHRI21 CHARACTER*4 IHRI22 CCCCC THE FOLLOWING 4 LINES WERE COMMENTED OUT APRIL 1992 CCCCC CHARACTER*4 IHRI31 CCCCC CHARACTER*4 IHRI32 CCCCC CHARACTER*4 IHRI41 CCCCC CHARACTER*4 IHRI42 CHARACTER*4 IHRIX1 CHARACTER*4 IHRIX2 C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IERRO4 C CHARACTER*4 ICTAR1 CHARACTER*4 ICTAR2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 INCLUDE 'DPCOHO.INC' DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZI.INC' DIMENSION YS(MAXOBV) DIMENSION TAGC2(MAXOBV) DIMENSION ITAGC2(MAXOBV) DIMENSION WAR(MAXOBV) DIMENSION WMR(MAXOBV) DIMENSION WMRT(MAXOBV) DIMENSION YST(MAXOBV) EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(1)) EQUIVALENCE (GARBAG(IGARB3),YS(1)) EQUIVALENCE (GARBAG(IGARB4),TAGC2(1)) EQUIVALENCE (GARBAG(IGARB5),YST(1)) EQUIVALENCE (GARBAG(IGARB6),WAR(1)) EQUIVALENCE (GARBAG(IGARB7),WMRT(1)) CCCCC MAY 1995. ADD FOLLOWING LINE TO EQUIVALENCE EQUIVALENCE (GARBAG(IGARB8),WMR(1)) EQUIVALENCE (IGARBG(IIGAR1),ITAGC2(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPNO' ISUBN2='RM ' C IFOUND='NO' IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MINN2=2 C SIGMA=(-999.0) AMU=(-999.0) SDSIGM=(-999.0) SDAMU=(-999.0) BPT1=(-999.0) BPT5=(-999.0) B1=(-999.0) B5=(-999.0) B10=(-999.0) B20=(-999.0) B50=(-999.0) B80=(-999.0) B90=(-999.0) B95=(-999.0) B99=(-999.0) B995=(-999.0) B999=(-999.0) C CCCCC THE FOLLOWING 4 LINES WERE ADDED APRIL 1992 ICUTMX=NUMBPW IF(IHOST1.EQ.'CDC '.OR.IHOST1.EQ.'CYBE')ICUTMX=48 IF(IHOST1.EQ.'205 ')ICUTMX=48 CUTOFF=2**(ICUTMX-3) C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'NORM')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGQ 54 FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)ICASPL,MAXN 56 FORMAT('ICASPL,MAXN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IFOUND,IERROR 57 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)MAXNPP 58 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)IX1TSC,IX2TSC,IY1TSC,IY2TSC 61 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)IX1TSV,IX2TSV,IY1TSV,IY2TSV 62 FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *********************************** C ** TREAT THE NORMAL PLOT CASE ** C *********************************** C C *************************** C ** STEP 11-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO1110 GOTO9000 C 1110 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO1190 C 1190 CONTINUE IFOUND='YES' ICASPL='NORM' C C ******************************************************** C ** STEP 12-- ** C ** CARRY OUT A GENERAL CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE 1 OR 2). ** C ******************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 13-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1390 DO1300J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO1310 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO1310 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO1320 1300 CONTINUE GOTO1390 1310 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1390 1320 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1390 1390 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'NORM')GOTO1395 WRITE(ICOUT,1391)ICASEQ,NUMARG,ILOCQ 1391 FORMAT('ICASEQ,NUMARG,ILOCQ = ',A4,2X,2I8) CALL DPWRST('XXX','BUG ') 1395 CONTINUE C C ******************************************************** C ** STEP 14-- ** C ** CARRY OUT A SPECIFIC CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE 1 OR 2). ** C ******************************************************** C ISTEPN='14' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=ILOCQ-1 IF(NUMVAR.EQ.1)GOTO1490 IF(NUMVAR.EQ.2)GOTO1490 GOTO1410 C 1410 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPNORM--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MECC')WRITE(ICOUT,1412) 1412 FORMAT(' FOR A NORMAL PLOT, ') IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1418) 1418 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1419) 1419 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1420) 1420 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1421) 1421 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1422)NUMVAR 1422 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1423) 1423 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1424)(IANS(I),I=1,IWIDTH) 1424 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1490 CONTINUE C C **************************************************************** C ** STEP 15-- * C ** EXAMINE THE VARIABLES-- * C ** HAS EACH VARIABLE * C ** ALREADY BEEN DEFINED? * C ** NOTE THAT ILISR1, ILISR2, * C ** IS THE LINE IN THE TABLE * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C ** NOTE THAT ICOLR1, ICOLR2, * C ** IS THE DATA COLUMN (1 TO 10+6) * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C **************************************************************** C ISTEPN='15' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICTAR1='FIRS' ICTAR2='T ' ILOCR1=1 IHRI11=IHARG(ILOCR1) IHRI12=IHARG2(ILOCR1) IHRIX1=IHRI11 IHRIX2=IHRI12 DO1510I=1,NUMNAM I2=I IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1519 IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1510 CONTINUE GOTO1570 1519 CONTINUE ILISR1=I2 ICOLR1=IVALUE(ILISR1) NIRIG1=IN(ILISR1) C IF(NUMVAR.LE.1)GOTO1590 ICTAR1='SECO' ICTAR2='ND ' ILOCR2=2 IHRI21=IHARG(ILOCR2) IHRI22=IHARG2(ILOCR2) IHRIX1=IHRI21 IHRIX2=IHRI22 DO1520I=1,NUMNAM I2=I IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1529 IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1520 CONTINUE GOTO1570 1529 CONTINUE ILISR2=I2 ICOLR2=IVALUE(ILISR2) NIRIG2=IN(ILISR2) GOTO1590 C 1560 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1561) 1561 FORMAT('***** ERROR IN DPNORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1562)ICTAR1,ICTAR2 1562 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1565) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1563)IHRIX1,IHRIX2 1563 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') 1565 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,') WRITE(ICOUT,1566) 1566 FORMAT(' BUT AS A PARAMETER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1567) 1567 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1568) 1568 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1569)(IANS(I),I=1,IWIDTH) 1569 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1571) 1571 FORMAT('***** ERROR IN DPNORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1572)ICTAR1,ICTAR2 1572 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1573)IHRIX1,IHRIX2 1573 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1575) 1575 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1576) 1576 FORMAT(' OF AVAILABLE VARIABLE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1577)IHRI11,IHRI12 1577 FORMAT(' THE VARIABLE IN QUESTION WAS ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1578) 1578 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1579)(IANS(I),I=1,IWIDTH) 1579 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1590 CONTINUE C C ****************************************************** C ** STEP 22-- ** C ** CHECK THAT VARIABLES 1 AND 2 HAVE ** C ** THE SAME NUMBER OF ELEMENTS. ** C ****************************************************** C 2100 CONTINUE ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMVAR.LE.1)GOTO2190 IF(NIRIG1.EQ.NIRIG2)GOTO2190 C 2110 CONTINUE WRITE(ICOUT,2111) 2111 FORMAT('***** ERROR IN DPNORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2113) 2113 FORMAT(' THE NUMBER OF OBSERVATIONS IN VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2114) 2114 FORMAT(' 1 AND 2 MUST BE THE SAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2115) 2115 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2116)IHRI11,IHRI12,NIRIG1 2116 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2117)IHRI21,IHRI22,NIRIG2 2117 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2120) 2120 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2121)(IANS(I),I=1,IWIDTH) 2121 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2190 CONTINUE C C ********************************************* C ** STEP 32-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ** BRANCH TO THE PROPER CASE. ** C ********************************************* C ISTEPN='32' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NLOCAL=NIRIG1 C IF(ICASEQ.EQ.'FULL')GOTO3210 IF(ICASEQ.EQ.'SUBS')GOTO3220 IF(ICASEQ.EQ.'FOR')GOTO3230 C 3210 CONTINUE DO3215I=1,NLOCAL ISUB(I)=1 3215 CONTINUE NQ=NLOCAL GOTO3250 C 3220 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO3250 C 3230 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR GOTO3250 C 3250 CONTINUE IF(NQ.GE.MINN2)GOTO3290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3251) 3251 FORMAT('***** ERROR IN DPNORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3252) 3252 FORMAT(' AFTER THE APPROPRIATE SUBSET ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3253) 3253 FORMAT(' HAS BEEN EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3254)IHRI11,IHRI12 3254 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3255) 3255 FORMAT(' (FOR WHICH AN NORMAL PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3256) 3256 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3257)MINN2 3257 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3258)NQ 3258 FORMAT(' SUCH WAS NOT THE CASE HERE (NQ = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3259) 3259 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3260)(IANS(I),I=1,IWIDTH) 3260 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3290 CONTINUE C C ********************************************** C ** STEP 33-- ** C ** FORM THE SUBSETTED VARIABLES ** C ** Y1(.) ** C ** Y2(.) ** C ** CONTAINING ** C ** THE RESPONSE VARIABLE ** C ** THE CENSOR-TAG VARIABLE ** C ** RESPECTIVELY. ** C ********************************************** C ISTEPN='33' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 IMAX=NIRIG1 IF(NQ.LT.NIRIG1)IMAX=NQ IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1WRITE(ICOUT,780)N,NIRIG1,NQ,IMAX 780 FORMAT(' N,NIRIG1,NQ,IMAX = ',4I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL DPWRST('XXX','BUG ') DO3300I=1,IMAX IF(ISUB(I).EQ.0)GOTO3300 J=J+1 C IJ=MAXN*(ICOLR1-1)+I IF(ICOLR1.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLR1.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLR1.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLR1.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLR1.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLR1.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLR1.EQ.MAXCP6)Y1(J)=TAGPLO(I) C IF(NUMVAR.LE.1)Y2(J)=1.0 IF(NUMVAR.LE.1)GOTO3300 IJ=MAXN*(ICOLR2-1)+I IF(ICOLR2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLR2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLR2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLR2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLR2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLR2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLR2.EQ.MAXCP6)Y2(J)=TAGPLO(I) C 3300 CONTINUE NS=J IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1WRITE(ICOUT,776)J,NS 776 FORMAT('J,NS = ',2I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL DPWRST('XXX','BUG ') C C ********************************************* C ** STEP 34-- ** C ** CHECK TO MAKE SURE THAT THE ** C ** COMBINATION OF CENSORING AND ** C ** SUBSETTING DOES NOT RESULT IN ** C ** TOO FEW DATA POINTS RESULTING ** C ** (AT LEAST 2) ** C ** WITH WHICH TO FORM A NORMAL PLOT. ** C ********************************************* C ISTEPN='34' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICOUNT=0 IF(NS.LE.2)ICOUNT=NS IF(NS.LE.2)GOTO3410 DO3400I=1,NS CCCCC WRITE(ICOUT,777)I,ICOUNT,NS,MINN2,Y2(I) CC777 FORMAT('I,ICOUNT,NS,MINN2,Y2(I) = ',I8,E15.7) CCCCC CALL DPWRST('XXX','BUG ') IF(Y2(I).LE.-0.0001.OR.Y2(I).GE.0.0001)ICOUNT=ICOUNT+1 3400 CONTINUE 3410 CONTINUE IF(ICOUNT.LE.MINN2)GOTO3450 GOTO3490 C 3450 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3451) 3451 FORMAT('***** ERROR IN DPNORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3452) 3452 FORMAT(' AFTER THE SPECIFIED CENSORING ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3453) 3453 FORMAT(' AND SUBSETTING HAS BEEN DONE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3454)IHRI11,IHRI12 3454 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3455) 3455 FORMAT(' (FOR WHICH A NORMAL PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3456) 3456 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3457)MINN2 3457 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3458)ICOUNT 3458 FORMAT(' SUCH WAS NOT THE CASE HERE (ICOUNT = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3459) 3459 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3460)(IANS(I),I=1,IWIDTH) 3460 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3490 CONTINUE C C **************************************************************** C ** STEP 41-- * C ** FORM THE VERTICAL AND HORIZONTAL AXIS * C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. * C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . * C ** THIS WILL BE BOTH ONES FOR BOTH CASES * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C **************************************************************** C ISTEPN='41' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'NORM') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPNOM2(Y1,Y2,NS,ICASPL,MAXN, 1IX1TSC,IX2TSC,IY1TSC,IY2TSC, 1IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1SIGMA,AMU,SDSIGM,SDAMU, 1BPT1,BPT5,B1,B5,B10,B20,B50,B80,B90,B95,B99,B995,B999, 1Y,X,D,NPLOTP,NPLOTV, 1YS,TAGC2,ITAGC2,WAR,WMR,WMRT,YST, 1IBUGG3,ISUBRO,IERROR) C C *************************************** C ** STEP 51-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='51' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) DO5100IPASS=1,17 CCCCC THE FOLLOWING 2 LINES WERE FIXED APRIL 1992 CCCCC IF(IPASS.EQ.1)IH='SIGMA' CCCCC IF(IPASS.EQ.1)IH2=' ' IF(IPASS.EQ.1)IH='SIGM' IF(IPASS.EQ.1)IH2='A ' IF(IPASS.EQ.2)IH='MU' IF(IPASS.EQ.2)IH2=' ' IF(IPASS.EQ.3)IH='SDSI' IF(IPASS.EQ.3)IH2='GMA ' IF(IPASS.EQ.4)IH='SDET' IF(IPASS.EQ.4)IH2='A ' C IF(IPASS.EQ.5)IH='BPT1' IF(IPASS.EQ.5)IH2=' ' IF(IPASS.EQ.6)IH='BPT5' IF(IPASS.EQ.6)IH2=' ' IF(IPASS.EQ.7)IH='B1 ' IF(IPASS.EQ.7)IH2=' ' IF(IPASS.EQ.8)IH='B5 ' IF(IPASS.EQ.8)IH2=' ' IF(IPASS.EQ.9)IH='B10 ' IF(IPASS.EQ.9)IH2=' ' IF(IPASS.EQ.10)IH='B20 ' IF(IPASS.EQ.10)IH2=' ' IF(IPASS.EQ.11)IH='B50 ' IF(IPASS.EQ.11)IH2=' ' IF(IPASS.EQ.12)IH='B80 ' IF(IPASS.EQ.12)IH2=' ' IF(IPASS.EQ.13)IH='B90 ' IF(IPASS.EQ.13)IH2=' ' IF(IPASS.EQ.14)IH='B95 ' IF(IPASS.EQ.14)IH2=' ' IF(IPASS.EQ.15)IH='B99 ' IF(IPASS.EQ.15)IH2=' ' IF(IPASS.EQ.16)IH='B995' IF(IPASS.EQ.16)IH2=' ' IF(IPASS.EQ.17)IH='B999' IF(IPASS.EQ.17)IH2=' ' DO5150I=1,NUMNAM I2=I IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO5180 5150 CONTINUE IF(NUMNAM.LT.MAXNAM)GOTO5170 WRITE(ICOUT,5151) 5151 FORMAT('***** ERROR IN DPNORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5152) 5152 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5153)MAXNAM 5153 FORMAT(' NAMES MUST BE AT MOST ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5154) 5154 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5155) 5155 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5156) 5156 FORMAT(' HAS JUST EXCEEDED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5157) 5157 FORMAT(' SUGGESTED ACTION--ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5158) 5158 FORMAT(' TO DETERMINE THE IMPORTANT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5159) 5159 FORMAT(' (VERSUS UNIMPORTANT) VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5160) 5160 FORMAT(' AND PARAMETERS, AND THEN REUSE SOME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5161) 5161 FORMAT(' OF THE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5162) 5162 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5163)(IANS(I),I=1,IWIDTH) 5163 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 5170 CONTINUE NUMNAM=NUMNAM+1 ILOC=NUMNAM IHNAME(ILOC)=IH IHNAM2(ILOC)=IH2 IUSE(ILOC)='P' IF(IPASS.EQ.1)VALUE(ILOC)=SIGMA IF(IPASS.EQ.2)VALUE(ILOC)=AMU IF(IPASS.EQ.3)VALUE(ILOC)=SDSIGM IF(IPASS.EQ.4)VALUE(ILOC)=SDAMU IF(IPASS.EQ.5)VALUE(ILOC)=BPT1 IF(IPASS.EQ.6)VALUE(ILOC)=BPT5 IF(IPASS.EQ.7)VALUE(ILOC)=B1 IF(IPASS.EQ.8)VALUE(ILOC)=B5 IF(IPASS.EQ.9)VALUE(ILOC)=B10 IF(IPASS.EQ.10)VALUE(ILOC)=B20 IF(IPASS.EQ.11)VALUE(ILOC)=B50 IF(IPASS.EQ.12)VALUE(ILOC)=B80 IF(IPASS.EQ.13)VALUE(ILOC)=B90 IF(IPASS.EQ.14)VALUE(ILOC)=B95 IF(IPASS.EQ.15)VALUE(ILOC)=B99 IF(IPASS.EQ.16)VALUE(ILOC)=B995 IF(IPASS.EQ.17)VALUE(ILOC)=B999 VAL=VALUE(ILOC) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(ILOC)=IVAL GOTO5100 C 5180 CONTINUE IF(IPASS.EQ.1)VALUE(I2)=SIGMA IF(IPASS.EQ.2)VALUE(I2)=AMU IF(IPASS.EQ.3)VALUE(I2)=SDSIGM IF(IPASS.EQ.4)VALUE(I2)=SDAMU IF(IPASS.EQ.5)VALUE(I2)=BPT1 IF(IPASS.EQ.6)VALUE(I2)=BPT5 IF(IPASS.EQ.7)VALUE(I2)=B1 IF(IPASS.EQ.8)VALUE(I2)=B5 IF(IPASS.EQ.9)VALUE(I2)=B10 IF(IPASS.EQ.10)VALUE(I2)=B20 IF(IPASS.EQ.11)VALUE(I2)=B50 IF(IPASS.EQ.12)VALUE(I2)=B80 IF(IPASS.EQ.13)VALUE(I2)=B90 IF(IPASS.EQ.14)VALUE(I2)=B95 IF(IPASS.EQ.15)VALUE(I2)=B99 IF(IPASS.EQ.16)VALUE(I2)=B995 IF(IPASS.EQ.17)VALUE(I2)=B999 VAL=VALUE(I2) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(I2)=IVAL GOTO5100 C 5100 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'NORM')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ICASPL,MAXN,NUMVAR 9014 FORMAT('ICASPL,MAXN,NUMVAR = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NIRIG1,NIRIG2 9015 FORMAT('NIRIG1,NIRIG2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NLOCAL,NQ,MINN2 9016 FORMAT('NLOCAL,NQ,MINN2 = ',3I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9029 DO9020I=1,NPLOTP WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9029 CONTINUE WRITE(ICOUT,9031)ICOUNT 9031 FORMAT('ICOUNT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)IX1TSC,IX2TSC,IY1TSC,IY2TSC 9041 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)IX1TSV,IX2TSV,IY1TSV,IY2TSV 9042 FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)SIGMA,AMU,SDSIGM,SDAMU 9043 FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4E15.7) CALL DPWRST('XXX','BUG ') DO9050I=1,NIRIG1 WRITE(ICOUT,9051)I,Y1(I),Y2(I),ISUB(I) 9051 FORMAT('I,Y1(I),Y2(I),ISUB(I) = ',I8,2E15.7,I8) CALL DPWRST('XXX','BUG ') 9050 CONTINUE WRITE(ICOUT,9061)IHRI11,IHRI12 9061 FORMAT('IHRI11,IHRI12 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9062)IHRI21,IHRI22 9062 FORMAT('IHRI21,IHRI22 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPNOM2(Y,TAGC,N,ICASPL,MAXN, 1IX1TSC,IX2TSC,IY1TSC,IY2TSC, 1IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1SIGMA,AMU,SDSIGM,SDAMU, 1BPT1,BPT5,B1,B5,B10,B20,B50,B80,B90,B95,B99,B995,B999, 1Y2,X2,D2,N2,NPLOTV, 1YS,TAGC2,ITAGC2,WAR,WMR,WMRT,YST, 1IBUGG3,ISUBRO,IERROR) C CCCCC NOTE--THIS SUBROUTINE WAS BASED ON DPWEI2--ITS WEIBULL ANALOGUE. C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C A NORMAL PLOT. C THE PLOT WILL CONSIST OF 6 COMPONENTS-- C 1) THE RAW DATA C 2) THE FITTED LINE C 3) THE HORIZONTAL 50% LINE C 4) THE VERTICAL 50% LINE C 5) 95% CONFIDENCE LIMITS C 6) 99% CONFIDENCE LIMITS C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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/6 C ORIGINAL VERSION--MAY 1990. C UPDATED --DECEMBER 1996. FIX VERTICAL 50% LINE LIMITS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL c CHARACTER*4 IX1TSC CHARACTER*4 IX2TSC CHARACTER*4 IY1TSC CHARACTER*4 IY2TSC C CHARACTER*4 IX1TSV CHARACTER*4 IX2TSV CHARACTER*4 IY1TSV CHARACTER*4 IY2TSV C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) DIMENSION TAGC(*) C DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C CCCCC DIMENSION YS(MAXOBV) CCCCC DIMENSION TAGC2(MAXOBV) CCCCC DIMENSION ITAGC2(MAXOBV) CCCCC DIMENSION WAR(MAXOBV) CCCCC DIMENSION WMR(MAXOBV) CCCCC DIMENSION WMRT(MAXOBV) CCCCC DIMENSION YST(MAXOBV) DIMENSION YS(*) DIMENSION TAGC2(*) DIMENSION ITAGC2(*) DIMENSION WAR(*) DIMENSION WMR(*) DIMENSION WMRT(*) DIMENSION YST(*) 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='DPWE' ISUBN2='I2 ' C IERROR='NO' C AN=N C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NOM2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNOM2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3,ISUBRO 52 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,MAXN,N,NPLOTV 53 FORMAT('ICASPL,MAXN,N,NPLOTV = ',A4,2X,I8,I8,I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO62 DO60I=1,N WRITE(ICOUT,61)I,Y(I),TAGC(I) 61 FORMAT('I,Y(I),TAGC(I) = ',I8,2E12.5) CALL DPWRST('XXX','BUG ') 60 CONTINUE 62 CONTINUE WRITE(ICOUT,71)IX1TSC,IX2TSC,IY1TSC,IY2TSC 71 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IX1TSV,IX2TSV,IY1TSV,IY2TSV 72 FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)SIGMA,AMU,SDSIGM,SDAMU 73 FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)BPT1,BPT5,B1,B5 74 FORMAT('BPT1,BPT5,B1,B5 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)B10,B20,B50,B80,B90 75 FORMAT(' B10,B20,B50,B80,B90 = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)B95,B99,B995,B999 76 FORMAT('B95,B99,B995,B999 = ',4E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.2)GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPNOM2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' MUST BE AT LEAST 2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114)N 1114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1119 CONTINUE C IF(N.GE.3)GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPNOM2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1123) 1123 FORMAT(' WAS EXACTLY EQUAL TO 2.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1129 CONTINUE C HOLD=Y(1) DO1130I=1,N IF(Y(I).NE.HOLD)GOTO1139 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPNOM2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)HOLD 1133 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1139 CONTINUE C DO1140I=1,N IF(Y(I).NE.0.0)GOTO1149 1140 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPNOM2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' ALL INPUT TAG VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' ARE IDENTICALLY EQUAL TO 0.0;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' THUS THERE ARE NO RESPONSE VARIABLE VALUES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1145) 1145 FORMAT(' REMAINING UPON WHICH TO DO A WEIBULL ANALYSIS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1149 CONTINUE C C *********************************************** C ** STEP 21-- ** C ** SORT THE DATA AND CARRY ALONG THE TAG ** C *********************************************** C CALL SORTC(Y,TAGC,N,YS,TAGC2) C DO2100I=1,N ITAGC2(I)=TAGC2(I)+0.1 2100 CONTINUE C C C *********************************************** C ** STEP 22-- ** C ** COMPUTE NORMAL ADUSTED RANKS ** C *********************************************** C C ----------------------------------------------- C SET INITIAL VALUE FOR SAVED ADJUSTED RANK. C SET INITIAL VALUE FOR RANK INCREMENT. C ----------------------------------------------- C SAVEAR=0.0 C I=0 ANUM=(AN+1.0)-SAVEAR ADENOM=1+(N-I) RANINC=ANUM/ADENOM C NVALID=0 DO2200I=1,N IF(ITAGC2(I).EQ.1)GOTO2210 GOTO2220 C C ----------------------------------------------- C TREAT THE VALID (TO BE INCLUDED) ITEM CASE. C COMPUTE THE ADJUSTED RANK. C SAVE THE ADJUSTED RANK. C DO NOT RECOMPUTE THE RANK INCREMENT. C ----------------------------------------------- C 2210 CONTINUE NVALID=NVALID+1 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1WRITE(ICOUT,2211)I,YS(I),TAGC2(I),ITAGC2(I),WAR(I) 2211 FORMAT('I,YS(I),TAGC2(I),ITAGC2(I),WAR(I) = ',I8,2E15.7, 1I8,E15.7) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1CALL DPWRST('XXX','BUG ') WAR(I)=SAVEAR+RANINC SAVEAR=WAR(I) GOTO2290 C C ----------------------------------------------- C TREAT THE SUSPENDED (= CENSORED) ITEM CASE C RECOMPUTE THE RANK INCREMENT. C DO NOT RECOMPUTE THE SAVED ADJUSTED RANK. C ----------------------------------------------- C 2220 CONTINUE ANUM=(AN+1.0)-SAVEAR ADENOM=1+(N-I) RANINC=ANUM/ADENOM GOTO2290 C 2290 CONTINUE 2200 CONTINUE C C ************************************ C ** STEP 23-- ** C ** DETERMINE THE NUMBER OF ** C ** "GOOD" ** C ** = NON-CENSORED/NON-SUSPENDED ** C ** DATA VALUES. ** C ************************************ C NSUB=0 DO2300I=1,N IF(ITAGC2(I).EQ.0)GOTO2300 NSUB=NSUB+1 2300 CONTINUE ANSUB=NSUB C C **************************************** C ** STEP 24-- ** C ** COMPUTE NORMAL MEDIAN RANKS ** C ** (FOR THE GOOD DATA ONLY) ** C **************************************** C DO2400I=1,N WMR(I)=(-999.0) IF(ITAGC2(I).EQ.0)GOTO2400 CCCCC WMR(I)=100.0*(WAR(I)-0.3)/(AN+0.4) IWARI=WAR(I)+0.1 CALL UNIME2(N,IWARI,POUT) WMR(I)=100.0*POUT IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1WRITE(ICOUT,2411)I,WAR(I),WMR(I) 2411 FORMAT('I,WAR(I),WMR(I) = ',I8,2E15.7) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1CALL DPWRST('XXX','BUG ') 2400 CONTINUE C C **************************************** C ** STEP 30-- ** C ** FIT THE DATA TO ESTIMATE ** C ** SIGMA (= SCALE PARAMETER) AND ** C ** AMU (= LOCATION PARAMETER) ** C **************************************** C C ****************************************** C ** STEP 31-- ** C ** TRANSFORM THE NORMAL MEDIAN RANKS ** C ****************************************** C DO3100I=1,N WMRT(I)=(-999.0) IF(ITAGC2(I).EQ.0)GOTO3100 CCCCC ARG1=100.0/(100.0-WMR(I)) CCCCC ARG2=ALOG(ARG1) CCCCC WMRT(I)=ALOG(ARG2) ARG1=WMR(I)/100.0 CALL NORPPF(ARG1,WMRT(I)) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1WRITE(ICOUT,3111)I,ITAGC2(I),WMR(I),WMRT(I) 3111 FORMAT('I,ITAGC2(I),WMR(I),WMRT(I) = ',2I8,2E15.7) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1CALL DPWRST('XXX','BUG ') 3100 CONTINUE C C ****************************************** C ** STEP 32-- ** C ** TRANSFORM THE SORTED DATA ** C ****************************************** C DO3200I=1,N CCCCC YST(I)=(-999.0) CCCCC IF(ITAGC2(I).EQ.0)GOTO3200 CCCCC IF(YS(I).GT.0.0)GOTO3219 CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3211) C3211 FORMAT('***** ERROR IN DPNOM2--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3212) C3212 FORMAT(' ZERO OR NEGATIVE DATA IS NOT PERMITTED') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3213) C3213 FORMAT(' IN A NORMAL PLOT.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3214) C3214 FORMAT(' THE ILLEGAL VALUE IS ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3215) C3215 FORMAT(' SUGGESTION--ADD A CONSTANT SO THAT ALL DATA') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3216) C3216 FORMAT(' IS POSITIVE, AND THEN REDO THE NORMAL PLOT.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 C3219 CONTINUE CCCCC YST(I)=ALOG(YS(I)) YST(I)=YS(I) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1WRITE(ICOUT,3221)I,ITAGC2(I),YS(I),YST(I) 3221 FORMAT('I,ITAGC2(I),YS(I),YST(I) = ',2I8,2E15.7) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1CALL DPWRST('XXX','BUG ') 3200 CONTINUE C C ****************************************** C ** STEP 33-- ** C ** CARRY OUT THE FIT OF ** C ** TRANSFORMED SORTED DATA VERSUS ** C ** TRANSFORMED NORMAL MEDIAN RANKS ** C ****************************************** C SUMX=0.0 SUMY=0.0 DO3310I=1,N IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1WRITE(ICOUT,3311)I,ITAGC2(I),YST(I),WMRT(I) 3311 FORMAT('I,ITAGC2(I),YST(I),WMRT(I) = ',2I8,2E15.7) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NOM2') 1CALL DPWRST('XXX','BUG ') IF(ITAGC2(I).EQ.0)GOTO3310 SUMX=SUMX+WMRT(I) SUMY=SUMY+YST(I) 3310 CONTINUE XBAR=SUMX/ANSUB YBAR=SUMY/ANSUB C SUMXX=0.0 SUMYY=0.0 SUMXY=0.0 DO3320I=1,N IF(ITAGC2(I).EQ.0)GOTO3320 SUMXX=SUMXX+(WMRT(I)-XBAR)*(WMRT(I)-XBAR) SUMYY=SUMYY+(YST(I)-YBAR)*(YST(I)-YBAR) SUMXY=SUMXY+(WMRT(I)-XBAR)*(YST(I)-YBAR) 3320 CONTINUE ASLOPE=0.0 IF(SUMXX.GT.0.0)ASLOPE=SUMXY/SUMXX AINTER=YBAR-ASLOPE*XBAR C SUMRR=0.0 SUMX2=0.0 DO3330I=1,N IF(ITAGC2(I).EQ.0)GOTO3330 RES=YST(I)-(AINTER+ASLOPE*WMRT(I)) SUMRR=SUMRR+RES*RES SUMX2=SUMX2+WMRT(I)*WMRT(I) 3330 CONTINUE RESVAR=SUMRR/(AN-2.0) RESSD=0.0 IF(RESVAR.GT.0.0)RESSD=SQRT(RESVAR) SDINTE=RESSD*SQRT(SUMX2/(AN*SUMXX)) SDSLOP=RESSD*SQRT(1.0/SUMXX) C C **************************************** C ** STEP 34-- ** C ** FORM ESTIMATES FOR ** C ** SIGMA (= SCALE PARAMETER) AND ** C ** AMU (= LOCATION PARAMETER) ** C **************************************** C IF(ASLOPE.GT.0.0)GOTO3339 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3331) 3331 FORMAT('***** INTERNAL ERROR IN DPNOM2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3332) 3332 FORMAT(' THE FITTED SLOPE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3333) 3333 FORMAT(' IS 0 OR NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3334) 3334 FORMAT(' WHICH WOULD YIELD AN IMPOSSIBLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3335) 3335 FORMAT(' VALUE FOR SIGMA = 1/SLOPE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3336)ASLOPE,AINTER 3336 FORMAT(' ASLOPE,AINTER = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3337)SUMX,SUMY,SUMXX,SUMYY,SUMXY 3337 FORMAT(' SUMX,SUMY,SUMXX,SUMYY,SUMXY = ',5E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3339 CONTINUE CCCCC SIGMA=1/ASLOPE CCCCC MU=EXP(AINTER) CCCCC SDSIGM=SIGMA*SIGMA*SDSLOP CCCCC SDMU=MU*SDINTE SIGMA=ASLOPE AMU=AINTER SDSIGM=SDSLOP SDAMU=SDINTE C C ************************************************ C ** STEP 35-- ** C ** FORM ESTIMATES FOR ** C ** BPT1= .1% POINT OF BEST-FIT DIST. ** C ** BPT5= .5% POINT OF BEST-FIT DIST. ** C ** B1 = 1% POINT OF BEST-FIT DIST. ** C ** B5 = 5% POINT OF BEST-FIT DIST. ** C ** B10 = 10% POINT OF BEST-FIT DIST. ** C ** B20 = 20% POINT OF BEST-FIT DIST. ** C ** B50 = 50% POINT OF BEST-FIT DIST. ** C ** B80 = 80% POINT OF BEST-FIT DIST. ** C ** B90 = 90% POINT OF BEST-FIT DIST. ** C ** B95 = 95% POINT OF BEST-FIT DIST. ** C ** B99 = 99% POINT OF BEST-FIT DIST. ** C ** B995= 99.5% POINT OF BEST-FIT DIST. ** C ** B999= 99.9% POINT OF BEST-FIT DIST. ** C ************************************************ C P=.001 CCCCC BPT1=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) BPT1=AMU+XOUT*SIGMA P=.005 CCCCC BPT5=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) BPT5=AMU+XOUT*SIGMA P=.01 CCCCC B1=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B1=AMU+XOUT*SIGMA P=.05 CCCCC B5=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B5=AMU+XOUT*SIGMA P=.10 CCCCC B10=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B10=AMU+XOUT*SIGMA P=.20 CCCCC B20=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B20=AMU+XOUT*SIGMA P=.50 CCCCC B50=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B50=AMU+XOUT*SIGMA P=.80 CCCCC B80=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B80=AMU+XOUT*SIGMA P=.90 CCCCC B90=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B90=AMU+XOUT*SIGMA P=.95 CCCCC B95=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B95=AMU+XOUT*SIGMA P=.99 CCCCC B99=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B99=AMU+XOUT*SIGMA P=.995 CCCCC B995=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B995=AMU+XOUT*SIGMA P=.999 CCCCC B999=MU*(ALOG(1.0/(1.0-P)))**(1.0/SIGMA) CALL NORPPF(P,XOUT) B999=AMU+XOUT*SIGMA C C **************************************** C ** STEP 41-- ** C ** SAVE OLD SETTINGS FOR ** C ** HORIZONTAL AXIS PLOT SCALE ** C ** VERTICAL AXIS PLOT SCALE ** C ** CHANGE ** C ** HORIZONTAL AXIS PLOT SCALE ** C ** TO LOG ** C ** CHANGE ** C ** VERTICAL AXIS PLOT SCALE ** C ** TO NORMAL ** C **************************************** IX1TSV=IX1TSC IX2TSV=IX2TSC IY1TSV=IY1TSC IY2TSV=IY2TSC C CCCCC IX1TSC='LOG' CCCCC IX2TSC='LOG' IX1TSC='LINE' IX2TSC='LINE' IY1TSC='NORM' IY2TSC='NORM' C C **************************************** C ** STEP 42-- ** C ** DETERMINE PLOT LIMITS FOR ** C ** PREDICTED LINE ** C **************************************** C P2=0.1 P=P2/100.0 CCCCC ARG1=1.0/(1.0-P) CCCCC TERM=ALOG(ARG1) CCCCC ARG2=1.0/SIGMA CCCCC PPF=MU*TERM**ARG2 CALL NORPPF(P,TERM) PPF=AMU+TERM*SIGMA XMIN=PPF C P2=99.9 P=P2/100.0 CCCCC ARG1=1.0/(1.0-P) CCCCC TERM=ALOG(ARG1) CCCCC ARG2=1.0/SIGMA CCCCC PPF=MU*TERM**ARG2 CALL NORPPF(P,TERM) PPF=AMU+TERM*SIGMA XMAX=PPF C XINC=(XMAX-XMIN)/100.0 C CCCCC XMIN2=ALOG10(XMIN) XMIN2=XMIN IF(XMIN2.GE.0.0)XMIN3=AINT(XMIN2) IF(XMIN2.LT.0.0)XMIN3=(-AINT(-XMIN2+1.0)) CCCCC XMIN4=10.0**XMIN3+0.001 XMIN4=XMIN3+0.001 C CCCCC XMAX2=ALOG10(XMAX) XMAX2=XMAX IF(XMAX2.GE.0.0)XMAX3=AINT(XMAX2) IF(XMAX2.LT.0.0)XMAX3=(-AINT(-XMAX2+1.0)) XMAX3=XMAX3+1.0 CCCCC XMAX4=10.0**XMAX3-0.001 XMAX4=XMAX3-0.001 C X50=AMU C C **************************************** C ** STEP 51-- ** C ** FORM PLOT COORDINATES ** C ** RAW (GOOD) DATA ** C ** PREDICTED LINE ** C ** HORIZONTAL 50% LINE ** C ** VERTICAL 50% LINE ** C ** 95% CONFIDENCE BAND ** C ** 99% CONFIDENCE BAND ** C **************************************** C J=0 DO5110I=1,N IF(ITAGC2(I).EQ.0)GOTO5110 J=J+1 Y2(J)=WMR(I) X2(J)=YS(I) D2(J)=1.0 5110 CONTINUE C X=XMIN-XINC DO5120I=1,10000 X=X+XINC IF(X.GT.XMAX)GOTO5129 CCCCC PRED=100.0*(1.0-EXP(-((X/MU)**SIGMA))) ARG=(X-AMU)/SIGMA CALL NORCDF(ARG,POUT) PRED=100.0*POUT J=J+1 Y2(J)=PRED X2(J)=X D2(J)=2.0 5120 CONTINUE 5129 CONTINUE C J=J+1 Y2(J)=50.0 X2(J)=XMIN4 D2(J)=3.0 J=J+1 Y2(J)=50.0 X2(J)=XMAX4 D2(J)=3.0 C J=J+1 CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1996 CCCCC Y2(J)=99.9 Y2(J)=99.5 X2(J)=X50 D2(J)=4.0 J=J+1 CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1996 CCCCC Y2(J)=0.1 Y2(J)=0.5 X2(J)=X50 D2(J)=4.0 C N2=J NPLOTV=3 C C **************************************** C ** STEP 61-- ** C ** RESTORE OLD SETTINGS FOR ** C ** HORIZONTAL AXIS PLOT SCALE ** C ** VERTICAL AXIS PLOT SCALE ** C **************************************** C CCCCC IX1TSC=IX1TSV CCCCC IX2TSC=IX2TSV CCCCC IY1TSC=IY1TSV CCCCC IY2TSC=IY2TSV C (THIS RESTORATION MUST BE DONE IN MAIN) C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNOM2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,MAXN,N2,IERROR 9012 FORMAT('ICASPL,MAXN,N2,IERROR = ',A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9021)IX1TSC,IX2TSC,IY1TSC,IY2TSC 9021 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IX1TSV,IX2TSV,IY1TSV,IY2TSV 9022 FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)AINTER,ASLOPE,SDINTE,SDSLOP 9031 FORMAT('AINTER,ASLOPE,SDINTE,SDSLOP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)SIGMA,AMU,SDSIGM,SDAMU 9032 FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)BPT1,BPT5,B1,B5 9034 FORMAT('BPT1,BPT5,B1,B5 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9035)B10,B20,B50,B80,B90 9035 FORMAT(' B10,B20,B50,B80,B90 = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9036)B95,B99,B995,B999 9036 FORMAT('B95,B99,B995,B999 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9037)RESSD 9037 FORMAT('RESSD = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)XMIN,XMIN2,XMIN3,XMIN4 9041 FORMAT('XMIN,XMIN2,XMIN3,XMIN4 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)XINC 9042 FORMAT('XINC = ',E15.7) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE FIXED APRIL 1992 CCCCC WRITE(ICOUT,9043)YMIN,YMIN2,YMIN3,YMIN4 C9043 FORMAT('YMIN,YMIN2,YMIN3,YMIN4 = ',4E15.7) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)XMIN,XMIN2,XMIN3,XMIN4 9043 FORMAT('XMIN,XMIN2,XMIN3,XMIN4 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)AMU,X50 9044 FORMAT('AMU,X50 = ',2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPNOR(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 LOGICAL NORS C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE INPUT COORDINATES DEFINE THE BACK CENTER AND THE FRONT CENTER C OF THE LOGICAL NOR. 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 LOGICAL NOR 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 LOGICAL NOR 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 LOGICAL NOR 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 INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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.'NOR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNOR--') 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='NOR' 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.2.AND. 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1GOTO1111 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1113 GOTO1130 C 1111 CONTINUE ITYPEO='ABSO' ILOCFN=1 GOTO1119 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='RELA' ILOCFN=2 GOTO1119 1119 CONTINUE C IF(ILOCFN.GT.NUMARG)GOTO1129 DO1120I=ILOCFN,NUMARG IF(IARGT(I).EQ.'NUMB')GOTO1120 GOTO1129 1120 CONTINUE IFOUND='YES' GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPNOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A LOGICAL NOR ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH THE MIDDLE OF THE FLATTER SIDE ', 1'AT THE POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' AND WITH THE POINTED END AT THE POINT 40 60') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' LOGICAL NOR 20 20 40 60 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' LOGICAL NOR 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 1159 CONTINUE C 1160 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X2=X1+X2 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 C 1170 CONTINUE CALL DPNOR2(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.'NOR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNOR--') 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 DPNOR2(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 LOGICAL NOR(= A NOR BOX) C WITH THE MIDDLE OF THE FLATTER SIDE C AT THE POINT (X1,Y1), C AND WITH THE MIDDLE OF THE POINTED SIDE C AT THE POINT (X2,Y2). C NOTE--THE HEIGHT OF THE BOX WILL BE EQUAL TO C THE ABOVE-DESCRIBED WIDTH OF THE BOX C (THAT IS, THE HEIGHT C OF THE BOX WILL BE EQUAL TO C THE WIDTH FROM (X1,Y1) TO (X2,Y2). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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.'NOR2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNOR2--') 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 LOGICAL NOR ** C ********************************* C C POWER=1.4 FACTOR=0.2 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) R=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 K=0 C X=R Y=-R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C DO5310I=271,451,10 PHI2=I-1 PHI2=PHI2*(2.0*3.1415926)/360.0 ABSCOS=ABS(COS(PHI2)) ABSSIN=ABS(SIN(PHI2)) X=R*(ABSCOS**POWER) Y=R*(ABSSIN**POWER) IF(SIN(PHI2).LT.0.0)Y=-Y X=X+R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 5310 CONTINUE C X=0 Y=R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C DO5320I=271,451,10 PHI2=I-1 PHI2=360.0-PHI2 PHI2=PHI2*(2.0*3.1415926)/360.0 X=FACTOR*R*COS(PHI2) Y=R*SIN(PHI2) CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 5320 CONTINUE C X=R Y=-R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 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 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 K=0 C X=-0.2*R Y=R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C DO5330I=271,451,10 PHI2=I-1 PHI2=360.0-PHI2 PHI2=PHI2*(2.0*3.1415926)/360.0 X=FACTOR*R*COS(PHI2) Y=R*SIN(PHI2) X=X-0.2*R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 5330 CONTINUE C NP=K C IPATT2='SOLI' IF(IREFSW(1).EQ.'ON') 1CALL DPFIRE(PX,PY,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) C C 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.'NOR2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPNOR2--') 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 DPNOSM(IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE NORMAL ORDER STATISTIC MEDIANS C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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 1986. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 NEWCOL CHARACTER*4 ICASEQ CHARACTER*4 ILEFT CHARACTER*4 ILEFT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPUO' ISUBN2='SM ' 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 IFOUND='YES' C NS2=0 C C *********************************************** C ** TREAT THE NORMAL ORDER STATISTIC MEDIANS CASE ** C ** 1) FOR A FULL VARIABLE, OR ** C ** 2) FOR PART OF A VARIABLE. ** C *********************************************** C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPNOSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,IBUGQ 52 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' NEWCOL='NO' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=3 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************************************** C ** STEP 3-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILEFT IS THE NAME OF THE VARIABLE * C ** ON THE LEFT. * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C ** NOTE THAT ICOLL IS THE DATA COLUMN (1 TO 12) * C ** FOR THE NAME OF THE LEFT. * C **************************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC ILEFT=IHOL(2) CCCCC ILEFT2=IHOL2(2) ILEFT=IHARG(1) ILEFT2=IHARG2(1) DO310I=1,NUMNAM I2=I IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO329 IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO380 310 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)GOTO320 GOTO330 C 320 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('***** ERROR IN DPNOSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,322) 322 FORMAT(' THE NUMBER OF VARIABLE AND/OR PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)MAXNAM 323 FORMAT(' NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ', 1I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,324) 324 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,326) 326 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,327) 327 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,328) 328 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 329 CONTINUE ILISTL=I2 GOTO330 C 330 CONTINUE NLEFT=0 ICOLL=NUMCOL+1 IF(ICOLL.GT.MAXCOL)GOTO340 GOTO390 C 340 CONTINUE WRITE(ICOUT,341) 341 FORMAT('***** ERROR IN DPNOSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,342) 342 FORMAT(' THE NUMBER OF DATA COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,343)MAXCOL 343 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,344) 344 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,345) 345 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,346) 346 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,347) 347 FORMAT(' AND THEN OVERWRITE SOME COLUMNS. EXAMPLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,348) 348 FORMAT(' IF LET X(I) = 3.14 FAILED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,349) 349 FORMAT(' THEN ONE MIGHT ENTER NAME X 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,350) 350 FORMAT(' (THEREBY EQUATING THE NAME X WITH COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,351) 351 FORMAT(' FOLLOWED BY LET X = 3.14') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,352) 352 FORMAT(' (WHICH WILL ACTUALLY OVERWRITE COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,353) 353 FORMAT(' WITH THE NUMERIC CONSTANTS 3.14)') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 380 CONTINUE ILISTL=I2 ICOLL=IVALUE(ILISTL) NLEFT=IN(ILISTL) C 390 CONTINUE C C ***************************************** C ** STEP 6-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER) ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='6' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO670 DO610J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO620 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO620 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO630 610 CONTINUE GOTO680 C 620 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO680 C 630 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO680 C 670 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,671) 671 FORMAT('***** INTERNAL ERROR IN DPNOSM') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,672) 672 FORMAT(' AT BRANCH POINT 5081--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,673) 673 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,674) 674 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,675)NUMARG 675 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,676) 676 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,677)(IANS(I),I=1,IWIDTH) 677 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 680 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO690 WRITE(ICOUT,681)NUMARG,ILOCQ,ICASEQ 681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') C 690 CONTINUE C C ****************************************************** C ** STEP 7-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE ** C ** (BASED ON THE QUALIFIER); ** C ** DETERMINE THE NUMBER (= NNOSM) ** C ** OF NORMAL ORDER STATISTIC MEDIANS TO BE GENERATED. C ** NOTE THAT THE VARIABLE NIISUB ** C ** IS THE LENGTH OF THE RESULTING ** C ** VARIABLE ISUB(.). ** C ** NOTE THAT DPFOR AUTOMATICALLY EXTENDS ** C ** THE INPUT LENGTH OF ISUB(.) IF NECESSARY. ** C ** (HENCE THE REDEFINITION OF NIISUB TO NINEW ** C ** AFTER THE CALL TO DPFOR. ** C ****************************************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO710 IF(ICASEQ.EQ.'SUBS')GOTO720 IF(ICASEQ.EQ.'FOR')GOTO730 C 710 CONTINUE IF(NEWNAM.EQ.'NO')NIISUB=NLEFT IF(NEWNAM.EQ.'YES')NIISUB=MAXN DO715I=1,NIISUB ISUB(I)=1 715 CONTINUE NNOSM=NIISUB GOTO750 C 720 CONTINUE NIISUB=MAXN CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR) NNOSM=NS GOTO750 C 730 CONTINUE IF(NEWNAM.EQ.'NO')NIISUB=NLEFT IF(NEWNAM.EQ.'YES')NIISUB=MAXN CALL DPFOR(NIISUB,NINEW,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NIISUB=NINEW NNOSM=NS GOTO750 C 750 CONTINUE C C ****************************************** C ** STEP 8-- ** C ** GENERATE NNOSM NORMAL ORDER ** C ** STATISTIC MEDIANS. ** C ** STORE THEM TEMPORARILY IN ** C ** THE VECTOR Y(.). ** C ****************************************** C ISTEPN='8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL UNIMED(NNOSM,Y) C DO800I=1,NNOSM CALL NORPPF(Y(I),Y(I)) 800 CONTINUE C C *********************************************************** C ** STEP 8-- ** C ** IF CALLED FOR (THAT IS, IF IBUGA3 IS ON), ** C ** PRINT OUT THE INTERMEDIATE VARIABLE Y(.). ** C ** THIS IS USEFUL FOR DIAGNOSTIC PURPOSES ** C ** IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE. ** C *********************************************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA3.EQ.'OFF')GOTO2090 WRITE(ICOUT,2051) 2051 FORMAT('OUTPUT FROM MIDDLE OF DPNOSM AFTER UNIMED ', 1'HAS BEEN CALLED--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2052)NNOSM 2052 FORMAT('NNOSM = ',I8) CALL DPWRST('XXX','BUG ') IF(NNOSM.LE.0)GOTO2090 DO2054I=1,NNOSM WRITE(ICOUT,2055)I,Y(I) 2055 FORMAT('I,Y(I) = ',I8,F12.5) CALL DPWRST('XXX','BUG ') 2054 CONTINUE C 2090 CONTINUE C C ****************************************************** C ** STEP 9-- ** C ** COPY THE ORDER STATISTIC MEDIANS ** C ** FROM THE INTERMEDIATE VECTOR Y(.) ** C ** TO THE APPROPRIATE COLUMN ** C ** (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR) ** C ** IN THE INTERNAL DATAPLOT DATA TABLE. ** C ****************************************************** C ISTEPN='10' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NS2=0 DO2100I=1,NIISUB IJ=MAXN*(ICOLL-1)+I IF(ISUB(I).EQ.0)GOTO2100 NS2=NS2+1 IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2) IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2) IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2) IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2) IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2) IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2) IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2) IF(NS2.EQ.1)IROW1=I IROWN=I 2100 CONTINUE C C ******************************************* C ** STEP 10-- ** C ** CARRY OUT THE LIST UPDATING AND ** C ** GENERATE THE INFORMATIVE PRINTING. ** C ******************************************* C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO')NINEW=NLEFT IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=MAXN IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN C IHNAME(ILISTL)=ILEFT IHNAM2(ILISTL)=ILEFT2 IUSE(ILISTL)='V' IVALUE(ILISTL)=ICOLL VALUE(ILISTL)=ICOLL IN(ILISTL)=NINEW C CCCCC IUSE(ICOLL)='V' CCCCC IVALUE(ICOLL)=ICOLL CCCCC VALUE(ICOLL)=ICOLL CCCCC IN(ICOLL)=NINEW C IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1 C DO4100J4=1,NUMNAM IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO4105 GOTO4100 4105 CONTINUE IUSE(J4)='V' IVALUE(J4)=ICOLL VALUE(J4)=ICOLL IN(J4)=NINEW 4100 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO4059 IF(IFEEDB.EQ.'OFF')GOTO4059 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4011)ILEFT,ILEFT2,NS2 4011 FORMAT('THE NUMBER OF VALUES GENERATED FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C IJ=MAXN*(ICOLL-1)+IROW1 IF(ICOLL.LE.MAXCOL)WRITE(ICOUT,4021)ILEFT,ILEFT2,V(IJ),IROW1 4021 FORMAT('THE FIRST COMPUTED VALUE OF ',A4,A4, 1' = ',E15.7,' (ROW ',I6,')') IF(ICOLL.LE.MAXCOL)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP1)WRITE(ICOUT,4021)ILEFT,ILEFT2,PRED(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP2)WRITE(ICOUT,4021)ILEFT,ILEFT2,RES(IROW1),IROW1 IF(ICOLL.EQ.MAXCP2)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP3)WRITE(ICOUT,4021)ILEFT,ILEFT2,YPLOT(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP3)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP4)WRITE(ICOUT,4021)ILEFT,ILEFT2,XPLOT(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP4)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP5)WRITE(ICOUT,4021)ILEFT,ILEFT2,X2PLOT(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP5)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP6)WRITE(ICOUT,4021)ILEFT,ILEFT2,TAGPLO(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP6)CALL DPWRST('XXX','BUG ') C IJ=MAXN*(ICOLL-1)+IROWN IF(ICOLL.LE.MAXCOL.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,V(IJ),IROWN 4031 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ',A4,A4, 1' = ',E15.7,' (ROW ',I6,')') IF(ICOLL.LE.MAXCOL.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP1.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN IF(ICOLL.EQ.MAXCP1.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP2.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN IF(ICOLL.EQ.MAXCP2.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP3.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP3.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP4.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP4.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP5.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP5.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP6.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN IF(ICOLL.EQ.MAXCP6.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(NS2.NE.1)GOTO4090 WRITE(ICOUT,4041) 4041 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4042) 4042 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.') CALL DPWRST('XXX','BUG ') 4090 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4112)ILEFT,ILEFT2,ICOLL 4112 FORMAT('THE CURRENT COLUMN FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4113)ILEFT,ILEFT2,NINEW 4113 FORMAT('THE CURRENT LENGTH OF ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 4059 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 DPNOSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGA3,IBUGQ 9013 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NS2 9015 FORMAT('NS2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NS,NIISUB,NNOSM 9016 FORMAT('NS,NIISUB,NNOSM = ',I8,I8,I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOPAC(IHARG,IARGT,ARG,NUMARG,DEFOAC, 1OPTACC,IFOUND,IERROR) C C PURPOSE--DEFINE THE OPTIMIZATION TOLERANCE. C ROUGHLY SPEAKING, THIS DEFINES THE DESIRED LENGTH C OF THE FINAL UNCERTAINTY REGION. C THE SPECIFIED OPTIMIZATION TOLERANCE VALUE WILL BE PLACED C IN THE FLOATING POINT VARIABLE OPTACC. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --DEFOAC (A FLOATING POINT VARIABLE) C OUTPUT ARGUMENTS--OPTACC (A FLOATING POINT VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/7 C ORIGINAL VERSION--JUNE 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ACCU')GOTO1110 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')GOTO1110 GOTO1199 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ACCU')GOTO1150 IF(IHARG(NUMARG).EQ.'TOLE')GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPOPAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR OPTIMIZATION TOLERANCE ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE THE THE ANALYST WILL BE CARRYING OUT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' AN OPTIMIZATION, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' AND SUPPOSE THE ANALYST WISHES THE FINAL ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' UNCERTAINITY INTERVAL TO BE .00001 OR SMALLER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' THEN THE ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' OPTIMIZATION TOLERANCE .00001 ') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE HOLD=DEFOAC GOTO1180 C 1160 CONTINUE HOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' OPTACC=HOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)OPTACC 1181 FORMAT('THE OPTIMIZATION TOLERANCE HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPOPDE C C PURPOSE--OPEN A GRAPHICS DEVICE C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C C 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 IERRG4='NO' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OPDE')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOPDE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IMANUF,IMODEL,IMODE2,IMODE3 52 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IGUNIT,IGCODE 53 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ISOFT,ISOFT2,ISOFT3 54 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IGBAUD 55 FORMAT('IGBAUD = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)IBUGG4,ISUBG4,IERRG4 56 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ***************************** C ** STEP 1-- ** C ** OPEN GRAPHICS DEVICES ** C ***************************** C CALL GROPDE C C ****************************** C ** STEP 2-- ** C ** OPEN GRAPHICS SOFTWARE ** C ****************************** C CCCCC CALL GROPSO C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OPDE')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOPDE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IMANUF,IMODEL,IMODE2,IMODE3 9012 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IGUNIT,IGCODE 9013 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISOFT,ISOFT2,ISOFT3 9014 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IGBAUD 9015 FORMAT('IGBAUD = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IBUGG4,ISUBG4,IERRG4 9016 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOPF0(IFILNU,IBUGS2,ISUBRO,IERROR) C C PURPOSE--OPEN ONE OF THE GENERAL DATAPLOT FILES. C IN PARTICULAR, OPEN THE FILE WITH C NUMERIC DESIGNATION IFILNU C WHERE IFILNU MAY BE THE UNIT NUMBER FOR C THE PLOT-1 FILE, C THE PLOT-2 FILE, C THE CONCLUSIONS FILE. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86/1 C ORIGINAL VERSION--JANUARY 1986. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGS2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CCCCC CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN 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='DPOP' ISUBN2='F0 ' C IFOUND='YES' IERROR='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'OPF0')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOPF0--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGS2,ISUBRO,IERROR 52 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IFILNU 53 FORMAT('IFILNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IPL1NU,IPL1ST 54 FORMAT('IPL1NU,IPL1ST = ',I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IPL2NU,IPL2ST 55 FORMAT('IPL2NU,IPL2ST = ',I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)ICONNU,ICONST 56 FORMAT('ICONNU,ICONST = ',I8,2X,A12) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************************** C ** STEP 11-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ** TO COPY OVER VARIABLES. ** C *************************************** C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'OPF0') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFILNU.EQ.IPL1NU)GOTO1110 IF(IFILNU.EQ.IPL2NU)GOTO1120 IF(IFILNU.EQ.ICONNU)GOTO1130 GOTO1200 C 1110 CONTINUE IOUNIT=IPL1NU IFILE=IPL1NA ISTAT=IPL1ST IFORM=IPL1FO IACCES=IPL1AC IPROT=IPL1PR ICURST=IPL1CS ISUBN0='OPF0' IERRFI='NO' GOTO1190 C 1120 CONTINUE IOUNIT=IPL2NU IFILE=IPL2NA ISTAT=IPL2ST IFORM=IPL2FO IACCES=IPL2AC IPROT=IPL2PR ICURST=IPL2CS ISUBN0='OPF0' IERRFI='NO' GOTO1190 C 1130 CONTINUE IOUNIT=ICONNU IFILE=ICONNA ISTAT=ICONST IFORM=ICONFO IACCES=ICONAC IPROT=ICONPR ICURST=ICONCS ISUBN0='OPF0' IERRFI='NO' GOTO1190 C 1190 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'OPF0')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 GOTO1300 C C **************************************** C ** STEP 12-- ** C ** IF NO MATCH FOUND FOR CASE, ** C ** THEN WRITE OUT AN ERROR MESSAGE ** C **************************************** C 1200 CONTINUE ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'OPF0') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** INTERNAL ERROR IN DPOPF0--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212)IFILNU 1212 FORMAT(' THE FILE WITH LOGICAL UNIT NUMBER = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' WAS NOT OPENED BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' THIS LOGICAL UNIT NUMBER DID NOT MATCH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' THE LOGICAL UNIT NUMBER OF ANY OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' THE DATAPLOT GENERAL FILES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)IPL1NU,IPL2NU,ICONNU 1217 FORMAT(' IPL1NU,IPL2NU,ICONNU = ',3I8) CALL DPWRST('XXX','BUG ') GOTO9000 C C **************************************** C ** STEP 13-- ** C ** CHECK TO SEE IF FILE MAY EXIST ** C **************************************** C 1300 CONTINUE ISTEPN='13' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'OPF0') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ISTAT.EQ.'NONE')GOTO1310 GOTO1390 1310 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** IMPLEMENTATION ERROR IN DPOPF0--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE DESIRED FILE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1313) 1313 FORMAT(' WAS NOT OPENED BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1314) 1314 FORMAT(' THE STATUS VARIABLE ISTAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT(' (AS SET IN SUBROUTINE INITFO)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316) 1316 FORMAT(' HAS THE SETTING NONE .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1317)IFILNU,ISTAT 1317 FORMAT(' IFILNU,ISTAT = ',I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1318) 1318 FORMAT(' CONTACT THE DATAPLOT IMPLEMENTOR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1319)IFILNU 1319 FORMAT(' AND HAVE THIS VARIABLE FOR FILE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1320) 1320 FORMAT(' SET TO THE PROPER VALUE (E.G.,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1321) 1321 FORMAT(' OLD, NEW, UNKNOWN)') CALL DPWRST('XXX','BUG ') GOTO9000 1390 CONTINUE C C ********************* C ** STEP 31-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='31' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'OPF0') 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 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'OPF0')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOPF0--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR 9012 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFILNU 9013 FORMAT('IFILNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IPL1NU,IPL1ST 9014 FORMAT('IPL1NU,IPL1ST = ',I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IPL2NU,IPL2ST 9015 FORMAT('IPL2NU,IPL2ST = ',I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)ICONNU,ICONST 9016 FORMAT('ICONNU,ICONST = ',I8,2X,A12) 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 ') CCCCC WRITE(ICOUT,9028)IENDFI C9028 FORMAT('IENDFI = ',A4) CCCCC 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 DPOPME(IHARG,NUMARG, 1IDEFOM,IDEFHS, 1IOPTME,IOPTHE, 1IBUGS2,IFOUND,IERROR) C C PURPOSE--DEFINE THE OPTIMIZATION METHOD C CAN BE: C C WHERE THE FIRST ARGUMENT DEFINES THE STEP SELECTION C STRATEGY AND THE SECOND ARGUMENT DEFINES THE TYPE C OF HESSIAN APPROXIMATION. C C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFOM (A CHARACTER VARIABLE) C --IDEFHS (A CHARACTER VARIABLE) C --IBUGS2 (A CHARACTER VARIABLE) C OUTPUT ARGUMENTS--IOPTME (A CHARACTER VARIABLE) C --IOPTME (A CHARACTER VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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--95/2 C ORIGINAL VERSION--FEBRUARY 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFOM CHARACTER*4 IDEFHS CHARACTER*4 IOPTME CHARACTER*4 IOPTHE CHARACTER*4 IBUGS2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 CHARACTER*4 IHOLD2 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGS2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOPME--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IDEFOM,IDEFHS 53 FORMAT('IDEFOM, IDEFHS = ',A4,1X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I) 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.1)GOTO1150 IF(NUMARG.EQ.2)GOTO1110 IF(NUMARG.EQ.3)GOTO1120 IF(NUMARG.GE.4)GOTO9000 C 1110 CONTINUE IHOLD1=IDEFOM IF(IHARG(2).EQ.'LINE')IHOLD1='LINE' IF(IHARG(2).EQ.'DOGL')IHOLD1='DOGL' IF(IHARG(2).EQ.'DOUB')IHOLD1='DOGL' IF(IHARG(2).EQ.'HOOK')IHOLD1='HOOK' GOTO1180 C 1120 CONTINUE IHOLD1=IDEFOM IF(IHARG(2).EQ.'LINE')IHOLD1='LINE' IF(IHARG(2).EQ.'DOGL')IHOLD1='DOGL' IF(IHARG(2).EQ.'DOUB')IHOLD1='DOGL' IF(IHARG(2).EQ.'HOOK')IHOLD1='HOOK' IHOLD2=IDEFHS IF(IHARG(3).EQ.'FINI')IHOLD2='FINI' IF(IHARG(3).EQ.'DIFF')IHOLD2='FINI' IF(IHARG(3).EQ.'BFGS')IHOLD2='BFGS' GOTO1180 C 1150 CONTINUE IHOLD1=IDEFOM IHOLD2=IDEFHS GOTO1180 C 1180 CONTINUE IFOUND='YES' IOPTME=IHOLD1 IOPTHE=IHOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IOPTME 1181 FORMAT( 1'THE OPTIMIZATION STEP SELECTION STRATEGY HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IOPTHE 1182 FORMAT( 1'THE OPTIMIZATION HESSIAN APPROXIMATION METHOD HAS JUST BEEN ', 1'SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C 9000 CONTINUE IF(IBUGS2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOPME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDEFOM,IDEFHS 9013 FORMAT('IDEFOM, IDEFHS = ',A4,1X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IOPTME,IOPTHE 9014 FORMAT('IOPTME, IOPTHE = ',A4,1X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOPPL(IGRASW, 1IBELSW,NUMRIN,IERASW, 1IBACCO) C C PURPOSE--CARRY OUT OPENING OPERATIONS C PRIOR TO THE GENERATION OF A PLOT. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 IGRASW CHARACTER*4 IBELSW CHARACTER*4 IERASW CHARACTER*4 IBACCO C C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OPPL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOPPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IMANUF,IMODEL,IMODE2,IMODE3 52 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IGUNIT,IGCODE 53 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ISOFT,ISOFT2,ISOFT3 54 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IGBAUD 55 FORMAT('IGBAUD = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)IGRASW 61 FORMAT('IGRASW= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)IBELSW,NUMRIN 62 FORMAT('IBELSW,NUMRIN= ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IERASW 63 FORMAT('IERASW= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IBACCO 64 FORMAT('IBACCO= ',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 1-- ** C ** KILL THE PROMPT, ** C ** IF ONE EXISTS ** C ************************ C CCCCC CALL GRKIPR C C **************************************************************** C ** STEP 2-- C ** EXIT OUT OF THE DIALOGUE (= MONITOR) MODE C ** AND MOVE TO GRAPHICS MODE. C ** THE GRAPHICS MODE ON VARIOUS TERMINALS C ** IS USUALLY OF 3 TYPES-- C ** 1. FOR TERMINALS WITH NO FORMAL GRAPHICS REGION AND C ** NO SEPARATE GRAPHICS PLANE C ** (AND THUS SUCCEDING GRAPHICS OUTPUT WILL C ** OVERWRITE THE NON-GRAPHICS DIALOGUE OUTPUT ON THE SCRE C ** THEN DO NOTHING. C ** 2. FOR THOSE TERMINALS IN WHICH THE SCREEN C ** IS SHARED BETWEEN A GRAPHICS REGION AND C ** A DIALOGUE (= MONITOR) REGION (USUALLY AT THE BOTTOM), C ** THEN GO TO THE GRAPHICS REGION. C ** 3. FOR TERMINALS WITH A FULL-SCREEN FOREGROUND C ** GRAPHICS PLANE THAT THE USER CAN FLIP-FLOP TO C ** AND WHICH IS INDEPENDENT OF THE DIALOGUE PLANE, C ** THEN GO TO THE GRAPHICS PLANE. C **************************************************************** C IGRASW='ON' CALL GRSEMO(IGRASW,PDIAXC,PDIAYC) C C ************************ C ** STEP 3-- ** C ** ERASE THE SCREEN ** C ** (IF CALLED FOR) ** C ************************ C IF(IERASW.EQ.'ON')CALL DPERSC(IBACCO) C C ************************************* C ** STEP 4-- ** C ** RING THE BELL (IF CALLED FOR) ** C ** TO SIGNAL A SCREEN ERASURE ** C ************************************* C IF(IBELSW.EQ.'OFF')GOTO1390 IF(NUMRIN.LE.0)GOTO1390 DO1300I=1,NUMRIN CALL GRRIBE 1300 CONTINUE 1390 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OPPL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOPPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IMANUF,IMODEL,IMODE2,IMODE3 9012 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IGUNIT,IGCODE 9013 FORMAT('IGUNIT,IGCODE = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISOFT,ISOFT2,ISOFT3 9014 FORMAT('ISOFT,ISOFT2,ISOFT3 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IGBAUD 9015 FORMAT('IGBAUD = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IGRASW 9021 FORMAT('IGRASW= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IBELSW,NUMRIN 9022 FORMAT('IBELSW,NUMRIN= ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)IERASW 9023 FORMAT('IERASW= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)IBACCO 9024 FORMAT('IBACCO= ',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 DPOPT(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, CCCCC FEBRUARY 1995. ADD IOPTME, IOPTHE TO ARGUMENT LIST. 1OPTACC,IOPTME,IOPTHE, 1ISUBRO,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IERROR) C C PURPOSE--TREAT THE LET CASE FOR C FINDING THE MINIMUM OF A FUNCTION. C EXAMPLE--UNIVARIATE CASE: C --LET A = OPTIMIZE X**3+2*X**2-4*X+5 WRT X FOR X = -100 200 C --LET A = F1 WRT X FOR X = 0 B C --USES FMIN ROUTINE FROM "NUMERICAL METHODS AND SOFTWARE", C BY KAHANER, MOLER, AND NASH C EXAMPLE--MULTI-UNIVARIATE CASE: C --(START VALUE FROM X(1) AND Y(1)) C --LET A = OPTIMIZE X**2+Y**2-X*Y WRT X Y C --LET A = F1 WRT X Y C --USES UNCMIN PACKAGE OF ROBERT SCHNABEL AND BARRY WEISS C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/6 C ORIGINAL VERSION--JUNE 1994. C UPDATED --MAY 1995. BUGS IN DECLARATIONS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IA CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 IERROR CCCCC ADD FOLLOWING LINE NOVEMBER 1994. CHARACTER*4 IANGLU CCCCC ADD FOLLOWING LINES MAY 1995 CHARACTER*4 IHP CHARACTER*4 IHP2 C CHARACTER*4 NEWNAM CHARACTER*4 IWD1 CHARACTER*4 IWD12 CHARACTER*4 IWD2 CHARACTER*4 IWD22 CHARACTER*4 ILAB CHARACTER*4 IKEY CHARACTER*4 IKEY2 CHARACTER*4 INCLUN CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASUP CHARACTER*4 IERRO2 CHARACTER*4 IHLEFT CHARACTER*4 IFOUN1 CHARACTER*4 IFOUN2 CHARACTER*4 IOLD CHARACTER*4 IOLD2 CHARACTER*4 INEW CHARACTER*4 INEW2 CHARACTER*4 IHPARN CHARACTER*4 IHPAR2 CHARACTER*4 IHL CHARACTER*4 IHL2 CHARACTER*4 IDUMV CHARACTER*4 IDUMV2 CHARACTER*4 IHOUT CHARACTER*4 IHOUT2 CHARACTER*4 IUOUT CHARACTER*4 IHLEF2 CHARACTER*4 IFOUND C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CCCCC FEBRUARY 1995. ADD FOLLOWING 2 LINES CHARACTER*4 IOPTME CHARACTER*4 IOPTHE CCCCC MAY 1995. ADD FOLLOWING LINE CHARACTER*4 ICASE CCCCC MAY 1995. ADD FOLLOWING LINE CHARACTER*4 ISUBN0 C CHARACTER*80 IFILE1 CHARACTER*12 ISTAT1 CHARACTER*12 IFORM1 CHARACTER*12 IACCE1 CHARACTER*12 IPROT1 CHARACTER*12 ICURS1 CHARACTER*4 IERRF1 CHARACTER*4 IENDF1 CHARACTER*4 IREWI1 C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IERRF2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 C C--------------------------------------------------------------------- C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IA(*) DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) C CCCCC FOLLOWING SECTION ADDED FEBRARY 1995 FOR OPTIMIZATION. C PARAMETER (MAXOPT=100) DIMENSION IDUMV(MAXOPT) DIMENSION IDUMV2(MAXOPT) C DIMENSION ILAB(10) DIMENSION IOLD(10) DIMENSION IOLD2(10) DIMENSION INEW(10) DIMENSION INEW2(10) DIMENSION VJUNK(1) C DOUBLE PRECISION TYPSIZ(MAXOPT) DOUBLE PRECISION XSTART(MAXOPT) DOUBLE PRECISION XPLS(MAXOPT) DOUBLE PRECISION GPLS(MAXOPT) DOUBLE PRECISION A(MAXOPT,MAXOPT) DOUBLE PRECISION WORK(MAXOPT,8) REAL XVALUE(MAXOPT) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOF2.INC' C C-----MAKE DUMMY COMMON BLOCK FOR MULTIVARIATE MINIMIZATION----------- C PARAMETER (IOPTCH=1000) PARAMETER (IOPTC2=100) C CHARACTER*4 IBUGAZ CHARACTER*4 ZTYPEH CHARACTER*4 ZW21HO CHARACTER*4 ZW22HO CHARACTER*4 ZIPARN CHARACTER*4 ZPARN2 CHARACTER*4 ZMODEL CHARACTER*4 ZIDUMV CHARACTER*4 ZDUMV2 C DIMENSION ZMODEL(IOPTCH) DIMENSION ZTYPEH(IOPTCH) DIMENSION ZW21HO(IOPTCH) DIMENSION ZW22HO(IOPTCH) DIMENSION Z2HOLD(IOPTCH) C DIMENSION ZPARAM(IOPTC2) DIMENSION ZIPARN(IOPTC2) DIMENSION ZPARN2(IOPTC2) DIMENSION ZIDUMV(IOPTC2) DIMENSION ZDUMV2(IOPTC2) DIMENSION LOCDUM(IOPTC2) C COMMON /OPTCMC/ IBUGAZ, ZTYPEH, ZW21HO, ZW22HO, ZIPARN, ZPARN2, & ZIDUMV, ZDUMV2, ZMODEL COMMON /OPTCMR/ ZPARAM, Z2HOLD, & NUMCHZ, NUMPVZ, NWHOLZ, NUMDVZ, LOCDUM CCCCC EXTERNAL OPTFCN 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='DPOP' ISUBN2='T ' 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 ILOCMX=0 NUMLIM=0 ILOC3=0 C C ************************************** C ** TREAT THE OPTIMIZATION SUBCASE ** C ** OF THE LET COMMAND ** C ************************************** C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'POPT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGCO,IBUGEV 53 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGQ 54 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' C MAXN2=MAXCHF MAXN3=MAXCHF C C ******************************************************* C ** STEP 2-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE VARIABLE NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C ******************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) DO2000I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))GOTO2100 2000 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)GOTO2200 GOTO2900 2200 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2201) 2201 FORMAT('***** ERROR IN DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2202) 2202 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2203)MAXNAM 2203 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2204) 2204 FORMAT(' ENTER STATUS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2205) 2205 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2206) 2206 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2207) 2207 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2100 CONTINUE ILISTL=I2 2900 CONTINUE C C ****************************************************** C ** STEP 3.1-- ** C ** EXTRACT THE RIGHT-SIDE FUNCTIONAL ** C ** EXPRESSION FROM THE INPUT COMMAND LINE ** C ** (STARTING WITH THE FIRST NON-BLANK LOCATION AFTER* C ** THE EQUAL SIGN AND ENDING WITH THE END OF THE LINE C ** OR WITH THE LAST NON-BLANK CHARACTER BEFORE WRT * C ** PLACE THE FUNCTION IN IFUNC2(.) . ** C ****************************************************** C ISTEPN='3.1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWD1=IHARG(3) IWD12=IHARG2(3) IWD2='WRT ' IWD22=' ' CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3500 C IWD1=IHARG(3) IWD12=IHARG2(3) IWD2='FOR ' IWD22=' ' CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3500 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3101) 3101 FORMAT('***** ERROR IN DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3102) 3102 FORMAT(' INVALID COMMAND FORM FOR OPTIMIZATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3103) 3103 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3104) 3104 FORMAT(' LET ... = OPTIMIZATION ... WRT ... ', 1'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3105) 3105 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3106)(IANS(I),I=1,IWIDTH) 3106 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3500 CONTINUE C C ***************************************************** C ** STEP 3.2-- ** C ** DETERMINE IF THE RIGHT-HAND SIDE IS ** C ** IN FUNCTION FORM OR IS IN EQUATION FORM. ** C ** IF IN EQUATION FORM, CONVERT TO FUNCTION FORM ** C ** BY REPLACING THE EQUAL SIGN BY A MINUS SIGN ** C ** AND ENCLOSING THE REST OF THE EXPRESSION IN ** C ** PARENTHESES. ** C ** PLACE THE OUTPUT FUNCTION BACK IN IFUNC2(.) ** C ***************************************************** C ISTEPN='3.2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO3600I=1,N2 I2=I IF(IFUNC2(I).EQ.'=')GOTO3610 3600 CONTINUE GOTO3900 3610 CONTINUE ILOCE2=I2 C IMIN=ILOCE2+1 IF(IMIN.GT.N2)GOTO3690 DO3650I=IMIN,N2 IREV=N2-I+IMIN IREVP1=IREV+1 IFUNC2(IREVP1)=IFUNC2(IREV) 3650 CONTINUE I=ILOCE2 IFUNC2(I)='-' I=ILOCE2+1 IFUNC2(I)='(' I=N2+2 IFUNC2(I)=')' N2=I 3690 CONTINUE C 3900 CONTINUE C C C ******************************************************* C ** STEP 4-- ** C ** DETERMINE IF THE EXPRESSION HAS ANY FUNCTION NAMES* C ** INBEDDED. IF SO, REPLACE THE FUNCTION NAMES ** C ** BY EACH FUNCTION'S DEFINITION. DO SO REPEATEDLY ** C ** UNTIL ALL FUNCTION REFERENCES HAVE BEEN ANNIHILATED C ** AND THE EXPRESSION IS LEFT ONLY WITH ** C ** CONSTANTS, PARAMETERS, AND VARIABLES--NO FUNCTIONS. C ** PLACE THE RESULTING FUNCTIONAL EXPRESSION INTO ** C ** IFUNC3(.) ** C ******************************************************* C ISTEPN='4' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IBUGA3.EQ.'OFF')GOTO5090 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ILAB(1)='INPU' ILAB(2)='T FU' ILAB(3)='NCTI' ILAB(4)='ON ' ILAB(5)=' ' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C WRITE(ICOUT,5081)IDUMV(1),IDUMV2(1) 5081 FORMAT('OPTIMIZATION VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') C 5090 CONTINUE C C ************************************* C ** STEP 5-- ** C ** EXTRACT QUALIFIER INFORMATION. ** C ************************************* C ISTEPN='5' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ****************************************************** C ** STEP 5.1-- ** C ** DETERMINE THE DUMMY VARIABLE FOR THE OPTIMIZATION* C ****************************************************** CCCCC FEBRUARY 1995. AT THIS STEP, CHECK FOR UNIVARIATE OR CCCCC MULTIVARIATE CASE. DO THIS BY CHECKING TO SEE IF THERE IS CCCCC A "FOR" CLAUSE. IF YES, THEN UNIVARIATE CASE. IF NO, THEN CCCCC HAVE A MULTIVARIATE CASE. C ISTEPN='5.1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASE='UNIV' C CCCCC FOLLOWING BLOCK ADDED FEBRUARY 1995. IKEY='FOR ' IKEY2=' ' ISHIFT=1 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5300 C CCCCC END ADDITION. C IKEY='WRT ' IKEY2=' ' ISHIFT=1 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5119 IDUMV(1)=IHOUT IDUMV2(1)=IHOUT2 NUMDV=1 GOTO5190 5119 CONTINUE C IKEY='FOR ' IKEY2=' ' ISHIFT=1 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5129 IDUMV(1)=IHOUT IDUMV2(1)=IHOUT2 NUMDV=1 GOTO5190 5129 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5181) 5181 FORMAT('***** ERROR IN DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5182) 5182 FORMAT(' INVALID COMMAND FORM FOR OPTIMIZATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5183) 5183 FORMAT(' NO VARIABLE FOR OPTIMIZATION DEFINED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5185) 5185 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5186) 5186 FORMAT(' LET ... = OPTIMIZATION ... WRT ... ', 1'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5187) 5187 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5189)(IANS(I),I=1,IWIDTH) 5189 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 5190 CONTINUE C C ************************************************** C ** STEP 5.2-- ** C ** DETERMINE THE LIMITS FOR THE OPTIMIZATION. ** C ************************************************** C ISTEPN='5.2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMLIM=0 C IKEY='FOR ' IKEY2=' ' ISHIFT=3 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5219 XMIN=VOUT NUMLIM=NUMLIM+1 5219 CONTINUE C IKEY='FOR ' IKEY2=' ' ISHIFT=4 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5239 IF(IHOUT.EQ.'TO '.AND.IHOUT2.EQ.' ')GOTO5229 XMAX=VOUT ILOCMX=ILOC2 NUMLIM=NUMLIM+1 5229 CONTINUE C IF(NUMLIM.EQ.2)GOTO5239 IKEY='FOR ' IKEY2=' ' ISHIFT=5 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5239 XMAX=VOUT ILOCMX=ILOC2 NUMLIM=NUMLIM+1 5239 CONTINUE C IF(NUMLIM.EQ.2)GOTO5290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5281) 5281 FORMAT('***** ERROR IN DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5282) 5282 FORMAT(' INVALID COMMAND FORM FOR OPTIMIZATION.') CALL DPWRST('XXX','BUG ') IF(NUMLIM.EQ.0)WRITE(ICOUT,5283) 5283 FORMAT(' NO LIMITS FOR OPTIMIZATION DEFINED.') IF(NUMLIM.EQ.0)CALL DPWRST('XXX','BUG ') IF(NUMLIM.EQ.1)WRITE(ICOUT,5284) 5284 FORMAT(' ONLY ONE LIMIT FOR OPTIMIZATION DEFINED.') IF(NUMLIM.EQ.1)CALL DPWRST('XXX','BUG ') IF(NUMLIM.NE.0.AND.NUMLIM.NE.1)WRITE(ICOUT,5285)NUMLIM 5285 FORMAT(' NUMBER OF LIMITS DEFINED = ',I8) IF(NUMLIM.NE.0.AND.NUMLIM.NE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5286) 5286 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5287) 5287 FORMAT(' LET ... = OPTIMIZATION ... WRT ... ', 1'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5288) 5288 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5289)(IANS(I),I=1,IWIDTH) 5289 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 5290 CONTINUE GOTO5999 C C ****************************************************** C ** STEP 5.3-- ** C ** MULTIVARIATE CASE-EXTRACT LIST OF VARIABLES ** C ****************************************************** C 5300 CONTINUE C ICASE='MULT' C IKEY='WRT ' IKEY2=' ' ISHIFT=1 ILOCA=1 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5311) 5311 FORMAT('***** ERROR IN DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5312) 5312 FORMAT(' INVALID COMMAND FORM FOR OPTIMIZATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5313) 5313 FORMAT(' NO WRT CLAUSE DEFINED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5316) 5316 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5317) 5317 FORMAT(' LET ... = OPTIMIZATION ... WRT ... ', 1 'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5318) 5318 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5319)(IANS(I),I=1,IWIDTH) 5319 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF IF(IUOUT.EQ.'V')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5411) 5411 FORMAT('***** ERROR IN DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5412)IHOUT,IHOUT2 5412 FORMAT(' DUMMY VARIABLE ',A4,A4,' WAS PREVIOUSLY ', 1 'DEFINED AS A VARIABLE RATHER THAN A PARAMETER.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSE IDUMV(1)=IHOUT IDUMV2(1)=IHOUT2 NUMDV=1 XSTART(1)=VOUT ENDIF C JMIN=ILOC1 NUMDV=NUMARG-JMIN IF(NUMDV.LE.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5511) 5511 FORMAT('***** ERROR IN DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5512) 5512 FORMAT(' NO FOR CLAUSE FOUND FOR 1-DIMENSIONAL CASE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5516) 5516 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5517) 5517 FORMAT(' LET ... = OPTIMIZATION ... WRT ... ', 1 'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5518) 5518 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5519)(IANS(I),I=1,IWIDTH) 5519 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C ICOUNT=1 ILOCA=JMIN ILOCB=NUMARG DO5600J=JMIN+2,NUMARG IKEY='WRT ' IKEY2=' ' ICOUNT=ICOUNT+1 ISHIFT=ICOUNT INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IUOUT.EQ.'V')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5611) 5611 FORMAT('***** ERROR IN DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5612)IHOUT,IHOUT2 5612 FORMAT(' DUMMY VARIABLE ',A4,A4,' WAS PREVIOUSLY ', 1 'DEFINED AS A VARIABLE RATHER THAN A PARAMETER.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSE IDUMV(ICOUNT)=IHOUT IDUMV2(ICOUNT)=IHOUT2 XSTART(ICOUNT)=VOUT ENDIF 5600 CONTINUE C GOTO6390 C 5999 CONTINUE C C ********************************************** C ** STEP 6.3-- ** C ** SCAN THE QUALIFIERS FOR VARIABLE, ** C ** PARAMETER, FUNCTION, AND VALUE CHANGES ** C ** IN THE FUNCTION. ** C ********************************************** C ISTEPN='6.3' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NCHANG=0 DO6300IFORI=1,10 C IKEY='FOR ' IKEY2=' ' ISHIFT=1 IF(IFORI.EQ.1)ILOCA=ILOCMX IF(IFORI.NE.1)ILOCA=ILOC3 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO6380 IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO6350 C ILOC3=ILOC2+2 IF(ILOC3.GT.NUMARG)GOTO6380 NCHANG=NCHANG+1 IOLD(NCHANG)=IHARG(ILOC2) IOLD2(NCHANG)=IHARG2(ILOC2) INEW(NCHANG)=IHARG(ILOC3) INEW2(NCHANG)=IHARG2(ILOC3) C 6300 CONTINUE 6350 CONTINUE GOTO6390 C 6380 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6301) 6301 FORMAT('***** ERROR IN DPOPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6302) 6302 FORMAT(' INVALID COMMAND FORM FOR OPTIMIZATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6303) 6303 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6304) 6304 FORMAT(' LET FUNCTION ... = OPTIMIZATION ... WRT ... ', 1'FOR ... = ... TO ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6305) 6305 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,6306)(IANS(I),I=1,IWIDTH) 6306 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 6390 CONTINUE C C ********************************************** C ** STEP 6.4-- ** C ** CARRY OUT THE VARIABLE, ** C ** PARAMETER, AND FUNCTION CHANGES ** C ** AND THEN PRINT OUT A BRIEF MESSAGE ** C ** INDICATING THAT THE CHANGES ** C ** HAVE BEEN MADE. ** C ********************************************** C ISTEPN='6.4' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO6490 IF(IFEEDB.EQ.'OFF')GOTO6490 IF(NCHANG.LE.0)GOTO6490 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ILAB(1)='PRE ' ILAB(2)='-CHA' ILAB(3)='NGE ' ILAB(4)='FUNC' ILAB(5)='TION' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG,IFUNC3,N3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C ILAB(1)='POST' ILAB(2)='-CHA' ILAB(3)='NGE ' ILAB(4)='FUNC' ILAB(5)='TION' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C 6490 CONTINUE C C ******************************************************* C ** STEP 6.7-- ** C ** MAKE A NON-CALCULATING PASS AT THE FUNCTION ** C ** SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES.* C ******************************************************* C ISTEPN='6.8' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IPASS=1 CALL COMPIM(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK, 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C *********************************************** C ** STEP 7-- ** C ** CHECK THAT ALL PARAMETERS ** C ** IN THE FUNCTION ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.). ** C ** ALSO CHECK THAT THE VARIABLE NAME ** C ** THAT FOLLOWS FOR (THAT IS, THE DUMMY ** C ** VARIABLE IS IN THE FUNCTION. ** C ** NOTE--ALL PARAMETERS AND VARIABLES ** C ** THAT ARE NOT FOUND IN IHNAME(.) ** C ** WILL BE AUTOMATICALLY SET TO 0.0 ** C ** (BUT ONLY TEMPORARILY); ** C ** THIS CONVENTION ALLOWS AN AUTOMATIC ** C ** SOLUTION TO THE PROBLEM OF OPTIMIZING ** C ** EQUATIONS (AS OPPOSED TO FUNCTIONS) ** C ** SINCE 'Y' WILL TYPICALLY BE SET TO ZERO ** C ** AS ONE WOULD WANT FOR OPTIMIZING ** C *********************************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IP=0 IV=0 IF(NUMPV.LE.0)GOTO7650 DO7600J=1,NUMPV IHPARN=IPARN(J) IHPAR2=IPARN2(J) DO7602JJ=1,NUMDV IF(IHPARN.EQ.IDUMV(JJ).AND.IHPAR2.EQ.IDUMV2(JJ))GOTO7620 7602 CONTINUE IHWUSE='P' MESSAG='YES' CALL CHECKN(IHPARN,IHPAR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'YES')GOTO7605 GOTO7610 C 7605 CONTINUE IP=IP+1 PARAM(J)=0.0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7606)IHPARN,IHPAR2 7606 FORMAT('NOTE--',A4,A4,' HAS BEEN TEMPORARILY SET TO ZERO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7607) 7607 FORMAT(' FOR THE OPTIMIZATION PROCESS.') CALL DPWRST('XXX','BUG ') GOTO7600 C 7610 CONTINUE IP=IP+1 PARAM(J)=VALUE(ILOCP) GOTO7600 C 7620 CONTINUE IV=IV+1 LOCDUM(IV)=J PARAM(J)=VALUE(LOCDUM(IV)) 7600 CONTINUE 7650 CONTINUE C C ********************************* C ** STEP 8-- ** C ** DETERMINE THE OPTIMIZATION ** C ********************************* C ISTEPN='8' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'POPT')GOTO7719 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7711) 7711 FORMAT('***** FROM DPOPT, IMMEDIATELY BEFORE CALLING ', 1'OPTIMIZATION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7712)N3,NUMPV 7712 FORMAT('N3,NUMPV = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7713)NUMDV,XMIN,XMAX 7713 FORMAT('NUMDV,XMIN,XMAX = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') DO7714I=1,NUMDV WRITE(ICOUT,7715)I,IDUMV(I),IDUMV2(I) 7715 FORMAT('I,IDUMV(I),IDUMV2(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 7714 CONTINUE WRITE(ICOUT,7716)IBUGA3,IBUGCO,IBUGEV 7716 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 7719 CONTINUE C IF(ICASE.EQ.'MULT')THEN C C COPY OVER DUMMY COMMON BLOCKS FOR OPTFUN ROUTINE C DO7805KK=1,MAXF3 ZMODEL(KK)=IFUNC3(KK) 7805 CONTINUE DO7810KK=1,IOPTCH ZTYPEH(KK)=ITYPEH(KK) ZW21HO(KK)=IW21HO(KK) ZW22HO(KK)=IW22HO(KK) Z2HOLD(KK)=W2HOLD(KK) 7810 CONTINUE DO7820KK=1,IOPTC2 ZPARAM(KK)=PARAM(KK) ZIPARN(KK)=IPARN(KK) ZPARN2(KK)=IPARN2(KK) ZIDUMV(KK)=IDUMV(KK) ZDUMV2(KK)=IDUMV2(KK) 7820 CONTINUE NUMCHZ=N3 NUMPVZ=NUMPV NWHOLZ=NWHOLD NUMDVZ=NUMDV IBUGAZ=IBUGA3 C IHP='OPTS' IHP2='CALE' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN FSCALE=0.0 ELSE FSCALE=VALUE(ILOCP) ENDIF C IHP='OPTM' IHP2='SG ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN MSG=8 ELSE MSG=VALUE(ILOCP)+0.5 ENDIF C IHP='OPTI' IHP2='TER ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN ITNLIM=150 ELSE ITNLIM=VALUE(ILOCP)+0.5 ENDIF C IHP='OPTD' IHP2='LT ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN DLT=0.0 ELSE DLT=VALUE(ILOCP) ENDIF C IHP='OPTG' IHP2='RDTL' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN GRADTL=0.0 ELSE GRADTL=VALUE(ILOCP) ENDIF C IHP='OPTS' IHP2='PMX ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN STEPMX=0.0 ELSE STEPMX=VALUE(ILOCP) ENDIF C IHP='OPTS' IHP2='TPTL' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN STEPTL=0.0 ELSE STEPTL=VALUE(ILOCP) ENDIF C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='POPT' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C CALL DPOPT3( 1 TYPSIZ,XSTART,XPLS,GPLS,A,WORK, 1 NUMDV, 1 OPTACC,IOPTME,IOPTHE, 1 ITNLIM,DLT,GRADTL,STEPMX,STEPTL,FSCALE,MSG, 1 FPLS, 1 ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 DO7900I=1,NUMDV XVALUE(I)=SNGL(XPLS(I)) 7900 CONTINUE C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='FIT3' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C DO7910I=1,NUMDV WRITE(IOUNI1,7911)SNGL(GPLS(I)) 7910 CONTINUE 7911 FORMAT(1X,E15.7) IF(IFEEDB.EQ.'OFF')GOTO7919 WRITE(ICOUT,7914) 7914 FORMAT(6X,'GRADIENTS WRITTEN OUT TO FILE DPST1F.DAT') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7916) 7916 FORMAT(6X,'HESSIAN MATRIX WRITTEN OUT TO FILE DPST2F.DAT') CALL DPWRST('XXX','WRIT') 7919 CONTINUE C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C ELSE CALL DPOPT2(IFUNC3,N3,PARAM,IPARN,IPARN2,NUMPV, 1 ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1 IDUMV,IDUMV2,NUMDV,XMIN,XMAX,OPTVAL, 1 OPTACC, 1 ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR) ENDIF C C ***************************************** C ** STEP 9-- ** C ** ENTER THE OPTIMIZED VALUE INTO THE** C ** DATAPLOT PARAMETER TABLE. ** C ** FOR UNIVARIATE CASE, SAVE SINGLE ** C ** PARAMETER VALUE. FOR MULTIVARIATE,** C ** SAVE INDIVIDUAL PARAMETERS AND ALSO** C ** A VARIABLE CONTAINING THESE VALUES ** C ***************************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'POPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASE.EQ.'MULT')THEN NJUNK=NUMDV IHL=IHLEFT IHL2=IHLEF2 ICASUP='V' CALL DPINVP(IHL,IHL2,ICASUP,XVALUE,NUMDV,FPLS,NJUNK, 1 ISUBN1,ISUBN2,IBUGA3,IERROR) IHL='OPTV' IHL2='ALUE' ICASUP='P' VJUNK(1)=REAL(XPLS(1)) CALL DPINVP(IHL,IHL2,ICASUP,VJUNK,NUMDV,FPLS,NJUNK, 1 ISUBN1,ISUBN2,IBUGA3,IERROR) DO8000I=1,NUMDV IHL=IDUMV(I) IHL2=IDUMV2(I) ICASUP='P' VALTMP=REAL(XPLS(I)) VJUNK(1)=VALTMP CALL DPINVP(IHL,IHL2,ICASUP,VJUNK,NUMDV,VALTMP,NJUNK, 1 ISUBN1,ISUBN2,IBUGA3,IERROR) 8000 CONTINUE C ELSE IHL=IHLEFT IHL2=IHLEF2 ICASUP='P' NJUNK=1 VJUNK(1)=OPTVAL CALL DPINVP(IHL,IHL2,ICASUP,VJUNK,NJUNK,OPTVAL,NJUNK, 1 ISUBN1,ISUBN2,IBUGA3,IERROR) ENDIF C C **************** C ** STEP 90-- ** C ** EXIT ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'POPT')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOPT--') CALL DPWRST('XXX','BUG ') DO9015I=1,NUMNAM WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I) 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=', 1I8,2X,A4,A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)NUMCHF,MAXCHF,IWIDTH,N2 9017 FORMAT('NUMCHF,MAXCHF,IWIDTH,N2 = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)(IFUNC(I),I=1,IWIDTH) 9018 FORMAT('IFUNC(.) = ',115A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)(IFUNC2(I),I=1,N2) 9019 FORMAT('IFUNC2(.) = ',115A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)N3 9020 FORMAT('N3 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)(IFUNC3(I),I=1,N3) 9021 FORMAT('IFUNC3(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)NUMPV 9022 FORMAT('NUMPV = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)IHLEFT,IHLEF2 9023 FORMAT('IHLEFT, IHLEF2 = ',A4,A4) CALL DPWRST('XXX','BUG ') DO9120I=1,NUMDV WRITE(ICOUT,9123)I,IDUMV(I),IDUMV2(I) 9123 FORMAT('I,IDUMV(I),IDUMV2(I) = ',I3,2X,A4,A4) CALL DPWRST('XXX','BUG ') 9120 CONTINUE WRITE(ICOUT,9024)ICASUP,IFOUND,IERROR 9024 FORMAT('ICASUP,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)XMIN,XMAX 9025 FORMAT('XMIN,XMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOPT2(MODEL,NUMCHA,PARAM,IPARN,IPARN2,NUMPV, 1ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IVARN,IVARN2,NUMVAR,XMIN,XMAX,FMIN, 1OPTACC, 1ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR) C C PURPOSE--COMPUTE THE MINIMUM OF A FUNCTION C BETWEEN THE LIMITS XMIN AND XMAX. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C NOTE--THIS ROUTINE USES THE FMIN ALGORITHM FOR THE BOOK C "NUMERICAL METHODS AND SOFTWARE" BY KAHANER, MOLER, NASH. C THE CODE IS "ILINED" INTO THIS ROUTINE RATHER THAN BEING C CALLED AS A SEPARATE FUNCTION. THE FOLLOWING IS THE C PROLOGUE OF THE FMIN ROUTINE, WHICH DOCUMENTS THE METHOD. C C***BEGIN PROLOGUE FMIN C***DATE WRITTEN 730101 (YYMMDD) C***REVISION DATE 730101 (YYMMDD) C***CATEGORY NO. G1A2 C***KEYWORDS ONE-DIMENSIONAL MINIMIZATION, UNIMODAL FUNCTION C***AUTHOR BRENT, R. C***PURPOSE An approximation to the point where F attains a minimum on C the interval (AX,BX) is determined as the value of the C function FMIN. C***DESCRIPTION C C From the book, "Numerical Methods and Software" by C D. Kahaner, C. Moler, S. Nash C Prentice Hall, 1988 C C The method used is a combination of golden section search and C successive parabolic interpolation. Convergence is never much C slower than that for a Fibonacci search. If F has a continuous C second derivative which is positive at the minimum (which is not C at AX or BX), then convergence is superlinear, and usually of the C order of about 1.324.... C C The function F is never evaluated at two points closer together C than EPS*ABS(FMIN) + (TOL/3), where EPS is approximately the C square root of the relative machine precision. If F is a unimodal C function and the computed values of F are always unimodal when C separated by at least EPS*ABS(XSTAR) + (TOL/3), then FMIN C approximates the abcissa of the global minimum of F on the C interval AX,BX with an error less than 3*EPS*ABS(FMIN) + TOL. C If F is not unimodal, then FMIN may approximate a local, but C perhaps non-global, minimum to the same accuracy. C C This function subprogram is a slightly modified version of the C ALGOL 60 procedure LOCALMIN given in Richard Brent, Algorithms for C Minimization Without Derivatives, Prentice-Hall, Inc. (1973). C C INPUT PARAMETERS C C AX (real) left endpoint of initial interval C BX (real) right endpoint of initial interval C F Real function of the form REAL FUNCTION F(X) which evaluates C F(X) for any X in the interval (AX,BX) C Must be declared EXTERNAL in calling routine. C TOL (real) desired length of the interval of uncertainty of the C final result ( .ge. 0.0) C C C OUTPUT PARAMETERS C C FMIN abcissa approximating the minimizer of F C AX lower bound for minimizer C BX upper bound for minimizer C C***REFERENCES RICHARD BRENT, ALGORITHMS FOR MINIMIZATION WITHOUT C DERIVATIVES, PRENTICE-HALL, INC. (1973). C***ROUTINES CALLED (NONE) C***END PROLOGUE FMIN REAL TOL REAL A,B,C,D,E,EPS,XM,P,Q,R,TOL1,TOL2,U,V,W REAL FU,FV,FW,FX,X REAL ABS,SQRT,SIGN C C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/6 C ORIGINAL VERSION--JUNE 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 MODEL CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IANGLU CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IVARN CHARACTER*4 IVARN2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IERROR C CHARACTER*4 ILAB CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CCCCC OCTOBER 1994. ADD FOLLOWING LINE CHARACTER*4 ISUBRO C C--------------------------------------------------------------------- C DIMENSION MODEL(*) DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) DIMENSION IVARN(*) DIMENSION IVARN2(*) C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION ILOCV(10) DIMENSION ILAB(10) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPOP' ISUBN2='T2 ' C IERROR='NO' IPASS=2 C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'OPT2')GOTO99 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPOPT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,IBUGCO,IBUGEV 52 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMCHA,NUMPV,NUMVAR 53 FORMAT('NUMCHA,NUMPV,NUMVAR = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)(MODEL(J),J=1,NUMCHA) 54 FORMAT('MODEL(I) = ',100A1) CALL DPWRST('XXX','BUG ') DO55I=1,NUMPV WRITE(ICOUT,56)I,PARAM(I),IPARN(I),IPARN2(I) 56 FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,E15.7,A4,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO59I=1,NUMVAR WRITE(ICOUT,61)I,IVARN(I),IVARN2(I) 61 FORMAT('I, IVARN(I),IVARN2(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 59 CONTINUE WRITE(ICOUT,62)XMIN,XMAX 62 FORMAT('XMIN, XMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') 99 CONTINUE C C *************************************************** C ** STEP 1-- ** C ** DETERMINE THE LOCATIONS (IN THE LIST IPARN) ** C ** OF THE VARIABLES OF THE FUNCTION. ** C *************************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO100I=1,NUMVAR IH=IVARN(I) IH2=IVARN2(I) DO200J=1,NUMPV J2=J IF(IPARN(J).EQ.IH.AND.IPARN2(J).EQ.IH2)GOTO210 200 CONTINUE 210 CONTINUE ILOCV(I)=J2 100 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** WRITE OUT PRELIMINARY SUMMARY INFORMATION ** C ************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO409 IF(IFEEDB.EQ.'OFF')GOTO409 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) 401 FORMAT('MINIMUM OF A FUNCTION') CALL DPWRST('XXX','BUG ') ILAB(1)=' ' ILAB(2)=' FU' ILAB(3)='NCTI' ILAB(4)='ON--' NUMWDL=4 CALL DPPRIF(ILAB,NUMWDL,MODEL,NUMCHA,IBUGA3) C WRITE(ICOUT,402)IVARN(1),IVARN2(1) 402 FORMAT(' OPTIMIZATION VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,403)XMIN 403 FORMAT(' SPECIFIED LOWER LIMIT OF INTERVAL = ',F20.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,404)XMAX 404 FORMAT(' SPECIFIED UPPER LIMIT OF INTERVAL = ',F20.10) CALL DPWRST('XXX','BUG ') 409 CONTINUE C C *************************** C ** STEP 3-- ** C ** FMIN CODE TO FIND ** C ** THE MINIMUM ** C *************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(OPTACC.GT.0.0)THEN TOL = OPTACC ELSE TOL = 1.0E-5 ENDIF C = 0.5*(3. - SQRT(5.0)) C C C is the squared inverse of the golden ratio C C EPS is approximately the square root of the relative machine C precision. C EPS = 1.0 10 EPS = EPS/2.0 TOL1 = 1.0 + EPS IF (TOL1 .GT. 1.0) GO TO 10 EPS = SQRT(EPS) C C initialization C CCCCC A = AX CCCCC B = BX A = AMIN1(XMIN,XMAX) B = AMAX1(XMIN,XMAX) V = A + C*(B - A) W = V X = V E = 0.0 CCCCC FX = F(X) C DO9100K=1,NUMVAR JLOC=ILOCV(K) PARAM(JLOC)=X 9100 CONTINUE C CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,FX, 1IBUGCO,IBUGEV,IERROR) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')WRITE(ICOUT,9103)X,FX 9103 FORMAT('X,FX = ',2E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')CALL DPWRST('XXX','BUG ') C FV = FX FW = FX C C main loop starts here C 20 XM = 0.5*(A + B) TOL1 = EPS*ABS(X) + TOL/3.0 TOL2 = 2.0*TOL1 C C check stopping criterion C IF (ABS(X - XM) .LE. (TOL2 - 0.5*(B - A))) GO TO 90 C C is golden-section necessary C IF (ABS(E) .LE. TOL1) GO TO 40 C C fit parabola C R = (X - W)*(FX - FV) Q = (X - V)*(FX - FW) P = (X - V)*Q - (X - W)*R Q = 2.0*(Q - R) IF (Q .GT. 0.0) P = -P Q = ABS(Q) R = E E = D C C is parabola acceptable C 30 IF (ABS(P) .GE. ABS(0.5*Q*R)) GO TO 40 IF (P .LE. Q*(A - X)) GO TO 40 IF (P .GE. Q*(B - X)) GO TO 40 C C a parabolic interpolation step C D = P/Q U = X + D C C F must not be evaluated too close to AX or BX C IF ((U - A) .LT. TOL2) D = SIGN(TOL1, XM - X) IF ((B - U) .LT. TOL2) D = SIGN(TOL1, XM - X) GO TO 50 C C a golden-section step C 40 IF (X .GE. XM) E = A - X IF (X .LT. XM) E = B - X D = C*E C C F must not be evaluated too close to X C 50 IF (ABS(D) .GE. TOL1) U = X + D IF (ABS(D) .LT. TOL1) U = X + SIGN(TOL1, D) CCCCC FU = F(U) C DO9200K=1,NUMVAR JLOC=ILOCV(K) PARAM(JLOC)=U 9200 CONTINUE C CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,FU, 1IBUGCO,IBUGEV,IERROR) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')WRITE(ICOUT,9203)U,FU 9203 FORMAT('U,FU = ',2E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2')CALL DPWRST('XXX','BUG ') C C C update A, B, V, W, and X C IF (FU .GT. FX) GO TO 60 IF (U .GE. X) A = X IF (U .LT. X) B = X V = W FV = FW W = X FW = FX X = U FX = FU GO TO 20 60 IF (U .LT. X) A = U IF (U .GE. X) B = U IF (FU .LE. FW) GO TO 70 IF (W .EQ. X) GO TO 70 IF (FU .LE. FV) GO TO 80 IF (V .EQ. X) GO TO 80 IF (V .EQ. W) GO TO 80 GO TO 20 70 V = W FV = FW W = U FW = FU GO TO 20 80 V = U FV = FU GO TO 20 C C end of main loop C 90 CONTINUE FMIN = X C C *************************** C ** STEP 5-- ** C ** WRITE OUT THE MINIMUM** C *************************** C ISTEPN='5' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO1490 IF(IFEEDB.EQ.'OFF')GOTO1490 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1405)FMIN 1405 FORMAT(' THE MINIMUM VALUE OCCURS AT = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 1490 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'OPT2')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOPT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IERROR 9021 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOPT3( 1TYPSIZ,XSTART,XPLS,GPLS,A,WORK, 1NUMDV, 1OPTACC,IOPTME,IOPTHE, 1ITNLIM,ADLT,AGRDTL,ASTPMX,ASTPTL,AFSCLE,MSG, 1AFPLS, 1ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR) C C PURPOSE--COMPUTE THE MINIMUM OF A FUNCTION C BETWEEN THE LIMITS XMIN AND XMAX. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C NOTE--THIS ROUTINE USES THE UNCMIN PACKAGE DESCIRBED IN THE C ARTICLE "A MODULAR SYSTEM OF ALGORITHMS FOR UNCONSTRAINED C MINIMIZATION" BY SCHNABEL, KOONTZ, AND WEISS. THIS CODE C IS DESIGNED IN A MODULAR FASHION TO SUPPORT A LARGE C NUMBER OF POTENTIAL OPTIMIZATION METHODS. IN PARTICULAR, C THE 3 MAIN CHOICES ARE: C 1) STEP SELECTION - LINE, DOGLEG, HOOK STEP C 2) GRADIENTS - NUMERIC OR ANALYTIC C 3) HESSIAN - ANALYTIC, BFGS UPDATE, OR FINITE C DIFFERENCES C THESE MAY BE COMBINED FOR A TOTAL OF 18 ALGORITHMS C (ACTUALLY 15 SINCE ANALYTIC HESSIANS WITH A NUMERICAL C FIRST DERIVATIVE IS NOT REALISTIC). AT THIS TIME, C DATAPLOT DOES NOT SUPPORT ANALYTIC GRADIENTS OR HESSIANS. C IN ADDITION, THE FUNCTION TO BE OPTIMIZED MUST BE C WRITTEN IN DATAPLOT'S FUNCTIONAL FORM. THAT IS, THERE C IS CURRENTLY NO PROVISION FOR A USER WRITTEN FUNCTION. C C NOTE--THIS FUNCTION DOES MINIMIZATION. TO MAXIMIZE, FIND THE C MINIMUM OF THE NEGATIVE OF THE FUNCTION. C C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/6 C ORIGINAL VERSION--JUNE 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CHARACTER*4 ISUBRO C CCCCC MAY 1995. ADD FOLLOWING LINES CHARACTER*4 IOPTME CHARACTER*4 IOPTHE C C--------------------------------------------------------------------- C PARAMETER (MAXOPT=100) C DOUBLE PRECISION TYPSIZ(MAXOPT) DOUBLE PRECISION XSTART(MAXOPT) DOUBLE PRECISION XPLS(MAXOPT) DOUBLE PRECISION GPLS(MAXOPT) DOUBLE PRECISION A(MAXOPT,MAXOPT) DOUBLE PRECISION WORK(MAXOPT,8) DOUBLE PRECISION DLT DOUBLE PRECISION GRADTL DOUBLE PRECISION STEPMX DOUBLE PRECISION STEPTL DOUBLE PRECISION FPLS DOUBLE PRECISION EPSM DOUBLE PRECISION FSCALE C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPOP' ISUBN2='T3 ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'OPT3')GOTO99 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPOPT3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,IBUGCO,IBUGEV 52 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 99 CONTINUE C C *************************** C ** STEP 1-- ** C ** DEFINE DEFAULT VALUES** C *************************** C C PARAMETERS C ---------- C N --> DIMENSION OF PROBLEM C XSTART(N) --> INITIAL GUESS TO SOLUTION (TO COMPUTE MAX STEP SIZE) C TYPSIZ(N) <-- TYPICAL SIZE FOR EACH COMPONENT OF X C FSCALE <-- ESTIMATE OF SCALE OF MINIMIZATION FUNCTION C METHOD <-- ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM C IEXP <-- =0 IF MINIMIZATION FUNCTION NOT EXPENSIVE TO EVALUATE C MSG <-- MESSAGE TO INHIBIT CERTAIN AUTOMATIC CHECKS + OUTPUT C NDIGIT <-- NUMBER OF GOOD DIGITS IN MINIMIZATION FUNCTION C ITNLIM <-- MAXIMUM NUMBER OF ALLOWABLE ITERATIONS C IAGFLG <-- =0 IF ANALYTIC GRADIENT NOT SUPPLIED C IAHFLG <-- =0 IF ANALYTIC HESSIAN NOT SUPPLIED C IPR <-- DEVICE TO WHICH TO SEND OUTPUT C DLT <-- TRUST REGION RADIUS C GRADTL <-- TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE ENOUGH C TO ZERO TO TERMINATE ALGORITHM C STEPMX <-- VALUE OF ZERO TO TRIP DEFAULT MAXIMUM IN OPTCHK C STEPTL <-- TOLERANCE AT WHICH SUCCESSIVE ITERATES CONSIDERED C CLOSE ENOUGH TO TERMINATE ALGORITHM C C SET TYPICAL SIZE OF X AND MINIMIZATION FUNCTION CCCCC APRIL 1996. CHANGE FOLLOWiNG LINE CCCCC DO 10 I=1,N DO 10 I=1,MAXOPT TYPSIZ(I)=1.0D0 10 CONTINUE IF(AFSCLE.NE.0.0)THEN FSCALE=DBLE(AFSCLE) ELSE FSCALE=1.0D0 ENDIF C C SET TOLERANCES C IF(ADLT.NE.0.0)THEN DLT=DBLE(ADLT) ELSE DLT=-1.0D0 ENDIF IF(AGRDTL.NE.0.0)THEN GRADTL=DBLE(AGRDTL) ELSE EPSM=DBLE(R1MACH(4)) CCCCC EPSM=D1MACH(4) GRADTL=EPSM**(1.0D0/3.0D0) ENDIF IF(ASTPMX.NE.0.0)THEN STEPMX=DBLE(ASTPMX) ELSE STEPMX=0.0D0 ENDIF IF(ASTPTL.NE.0.0)THEN STEPTL=DBLE(ASTPTL) ELSE STEPTL=DSQRT(EPSM) ENDIF C C SET FLAGS METHOD=1 IF(IOPTME.EQ.'DOGL')METHOD=2 IF(IOPTME.EQ.'HOOK')METHOD=3 IEXP=0 IF(IOPTHE.EQ.'FINI')IEXP=0 IF(IOPTHE.EQ.'BFGS')IEXP=1 CCCCC DATAPLOT NOTE. THE UNCMIN ROUTINE IS DOUBLE PRECISION. CCCCC HOWEVER, DATAPLOT'S FUNCTION EVALUATION IS ONLY SINGLE CCCCC PRECISION. USE THE DEFAULT METHOD FROM OPTCHK, BUT USE CCCCC SINGLE PRECISION VALUE RATHER THAN DOUBLE PRECISION. CCCCC NDIGIT=-1 CCCCC NDIGIT=-LOG10(R1MACH(4)) CCCCC NDIGIT=-LOG10(D1MACH(4)) NDIGIT=-99 C ITNLIM=150 IAGFLG=0 IAHFLG=0 IPR2=IPR C CALL OPTIF9( CCCCC1MAXOPT,NUMDV,XSTART,OPTFCN,TYPSIZ,FSCALE, 1MAXOPT,NUMDV,XSTART,TYPSIZ,FSCALE, 1METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR2, 1DLT,GRADTL,STEPMX,STEPTL, 1XPLS,FPLS,GPLS,ITRMCD,A,WORK) AFPLS=SNGL(FPLS) IF(ITRMCD.EQ.4)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1001)ITNLIM 1001 FORMAT('**** ERROR FROM OPTIMIZATION ROUTINE. MAXIMUM ', * 'NUMBER OF ITERATIONS (',I5,') EXCEEDED.') CALL DPWRST('XXX','BUG') ELSEIF(ITRMCD.EQ.0)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1011) 1011 FORMAT('**** ERROR FROM OPTIMIZATION ROUTINE. ERRONEOUS ', * 'INPUT DATA DETECTED BY OPTIF9 ROUTINE.') CALL DPWRST('XXX','BUG') ELSEIF(ITRMCD.EQ.5)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1021) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1022) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1023) CALL DPWRST('XXX','BUG') 1021 FORMAT( &'**** ERROR FROM OPTIMIZATION ROUTINE. MAXIMUM STEP SIZE (', &E15.7,') EXCEEDED ') 1022 FORMAT( &' 5 CONSECUTIVE TIMES. EITHER THE FUNCTION IS UNBOUNDED ', &'FROM BELOW, BECOMES ASYMPTOTIC') 1023 FORMAT( &' TO A FINIT LIMIT FROM ABOVE, OR THE MAXIMIM STEP SIZE IS ', &'TOO SMALL (LET OPTSTMX = TO CHANGE).') ELSEIF(ITRMCD.EQ.1)THEN IERROR='NO' IF(IPRINT.EQ.'OFF')GOTO1039 IF(IFEEDB.EQ.'OFF')GOTO1039 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1031) 1031 FORMAT('**** RELATIVE GRADIENT IS CLOSE TO ZERO. THE ', * 'CURRENT ITERATE IS PROBABLY A SOLUTION.') CALL DPWRST('XXX','BUG') 1039 CONTINUE ELSEIF(ITRMCD.EQ.2)THEN IERROR='NO' IF(IPRINT.EQ.'OFF')GOTO1049 IF(IFEEDB.EQ.'OFF')GOTO1049 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1041) 1041 FORMAT('**** SUCCESSIVE ITERATES WITHIN TOLERANCE. THE ', * 'CURRENT ITERATE IS PROBABLY A SOLUTION.') CALL DPWRST('XXX','BUG') 1049 CONTINUE ELSEIF(ITRMCD.EQ.3)THEN IERROR='NO' IF(IPRINT.EQ.'OFF')GOTO1059 IF(IFEEDB.EQ.'OFF')GOTO1059 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1051) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1052) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1053)STEPTL CALL DPWRST('XXX','BUG') WRITE(ICOUT,1054) CALL DPWRST('XXX','BUG') 1059 CONTINUE 1051 FORMAT('**** LAST GLOBAL STEP FAILED TO LOCATE A POINT LOWER', * ' THAN CURRENT ITERATE. EITHER IT IS A ') 1052 FORMAT(' APPROXIMATE LOCAL MINIMUM OF THE FUNCTION, THE ', * ' FUNCTION IS TOO NON-LINEAR FOR') 1053 FORMAT(' THIS ALGORITHM, OR THE STEP TOLERANCE (',E15.7, * ') IS TOO LARGE (CAN ') 1054 FORMAT(' CHANGE WITH: LET OPTSTPTL = ') ENDIF C C *************************** C ** STEP 5-- ** C ** WRITE OUT THE MINIMUM** C *************************** C ISTEPN='5' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OPT3') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO1490 IF(IFEEDB.EQ.'OFF')GOTO1490 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1401KK=1,NUMDV WRITE(ICOUT,1405)KK,XPLS(KK) 1405 FORMAT(' THE MINIMUM VALUE OCCURS AT = ',I5,1X,E15.7) CALL DPWRST('XXX','BUG ') 1401 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 1490 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'OPT3')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOPT3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IERROR 9021 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOR(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 LOGICAL ORS C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE INPUT COORDINATES DEFINE THE BACK CENTER AND THE FRONT CENTER C OF THE LOGICAL OR. 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 LOGICAL OR 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 LOGICAL OR 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 LOGICAL OR 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 INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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.'OR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOR--') 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='OR' 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.2.AND. 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1GOTO1111 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1113 GOTO1130 C 1111 CONTINUE ITYPEO='ABSO' ILOCFN=1 GOTO1119 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='RELA' ILOCFN=2 GOTO1119 1119 CONTINUE C IF(ILOCFN.GT.NUMARG)GOTO1129 DO1120I=ILOCFN,NUMARG IF(IARGT(I).EQ.'NUMB')GOTO1120 GOTO1129 1120 CONTINUE IFOUND='YES' GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A LOGICAL OR ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH THE MIDDLE OF THE FLATTER SIDE ', 1'AT THE POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' AND WITH THE POINTED END AT THE POINT 40 60') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' LOGICAL OR 20 20 40 60 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' LOGICAL OR 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 1159 CONTINUE C 1160 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X2=X1+X2 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 C 1170 CONTINUE CALL DPOR2(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.'OR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOR--') 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 DPOR2(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 LOGICAL OR (= AN OR BOX) C WITH THE MIDDLE OF THE FLATTER SIDE C AT THE POINT (X1,Y1), C AND WITH THE MIDDLE OF THE POINTED SIDE C AT THE POINT (X2,Y2). C NOTE--THE HEIGHT OF THE BOX WILL BE EQUAL TO C THE ABOVE-DESCRIBED WIDTH OF THE BOX C (THAT IS, THE HEIGHT C OF THE BOX WILL BE EQUAL TO C THE WIDTH FROM (X1,Y1) TO (X2,Y2). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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.'OR2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOR2--') 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 LOGICAL OR ** C ********************************* C POWER=1.4 FACTOR=0.2 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) R=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 K=0 C X=R Y=-R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C DO5210I=271,451,5 PHI2=I-1 PHI2=PHI2*(2.0*3.1415926)/360.0 ABSCOS=ABS(COS(PHI2)) ABSSIN=ABS(SIN(PHI2)) X=R*(ABSCOS**POWER) Y=R*(ABSSIN**POWER) IF(SIN(PHI2).LT.0.0)Y=-Y X=X+R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 5210 CONTINUE C X=0 X=X-FACTOR*R Y=R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C DO5220I=271,451,5 PHI2=I-1 PHI2=360.0-PHI2 PHI2=PHI2*(2.0*3.1415926)/360.0 X=FACTOR*R*COS(PHI2) X=X-FACTOR*R Y=R*SIN(PHI2) CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 5220 CONTINUE C X=R Y=-R CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP 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 OR ** 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.'OR2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOR2--') 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 DPORCO(IHARG,IARGT,ARG,NUMARG, 1AORIXC,AORIYC,AORIZC, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE (X,Y,Z) ORIGIN COORDINATES CONTAINED IN THE C 3 VARAIBLES AORIXC,AORIYC,AORIZC C SUCH ORIGIN COORDINATES ARE USED IN 3-DIMENSIONAL PLOTS. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG C OUTPUT ARGUMENTS--AORIXC = X-COORDINATE OF ORIGIN C --AORIYC = Y-COORDINATE OF ORIGIN C --AORIZC = Z-COORDINATE OF ORIGIN C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1978. C UPDATED --SEPTEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.0)GOTO1199 IF(IHARG(1).NE.'COOR')GOTO1199 IF(NUMARG.EQ.1)GOTO1150 IF(IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB'.AND. 1IARGT(4).EQ.'NUMB')GOTO1160 GOTO1110 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 C IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPEYCO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR ORIGIN COORDINATES ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE IT IS DESIRED TO POSITION ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' THE AXES ORIGIN FOR A 3 DIMENSIONAL PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' AT (IN UNITS OF THE PLOTTED DATA)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' (X=500, Y=25000, Z=.03)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) 1129 FORMAT(' THEN THE ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' ORIGIN COORDINATES 500 2500 .03') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE AORIXC=CPUMIN AORIYC=CPUMIN AORIZC=CPUMIN GOTO1180 C 1160 CONTINUE AORIXC=ARG(2) AORIYC=ARG(3) AORIZC=ARG(4) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1185) 1185 FORMAT('THE (X,Y,Z) ORIGIN COORDINATES HAVE JUST BEEN SET TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)AORIXC 1186 FORMAT(' --X = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1187)AORIYC 1187 FORMAT(' --Y = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1188)AORIZC 1188 FORMAT(' --Z = ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPORDE(IHARG,IHARG2,NUMARG, 1IODRD1,IODRD2,IODRD3,IODRD4,IWEIN1,IWEIN2, 1ICASOD,IFOUND,IERROR) C C PURPOSE--DEFINE THE USER VARIABLE NAMES THAT DEFINE THE C DELTAS FOR ORTHOGONAL DISTANCE FITS. NOTE THAT THERE C ARE THREE SETS OF VARIABLES FOR THE DELTAS: C 1) YOU CAN DEFINE FROM 1 TO 20 VARIABLE NAMES C THAT SPECIFY THE WEIGHTS FOR THE DELTAS. C 2) YOU CAN DEFINE FROM 1 TO 20 VARIABLE NAMES C THAT SPECIFY STARTING VALUES FOR THE DELTAS. C NOTE THAT FOR MANY PROBLEMS, IT IS NOT NECESSARY C TO SPECIFY STARTING VALUES. C IF IODRD1(1) = 'OFF', ALL DELTA WEIGHTS ARE C SET TO ZERO. ONE VARIABLE CAN BE DEFINED TO SET C A UNIQUE DELTA WEIGHT FOR EACH COLUMN OR A SEPARATE C WEIGHT DELTA WEIGHT VARIABLE CAN BE DEFINED FOR EACH C COLUMN. MULTIPLE VARIABLE NAMES IMPLIES EACH ELEMENT C OF THE DESIGN MATRIX HAS ITS OWN DELTA WEIGHT C VARIABLE DEFINED. STARTING VALUES FOR THE DELTAS C THEMSELVES CAN ONLY BE SPECIFIED AS VARIABLE C NAMES (I.E., ONE VARIABLE FOR EACH COLUMN OF THE C DESIGN MATRIX). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IHARG2 (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IODRD1 (A HOLLERITH VARIABLE) C --IODRD2 (A HOLLERITH VARIABLE) C --IODRD3 (A HOLLERITH VARIABLE) C --IODRD4 (A HOLLERITH VARIABLE) C --IWEIN1 (A HOLLERITH VARIABLE) C --IWEIN2 (A HOLLERITH VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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--2001/4 C ORIGINAL VERSION--APRIL 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C PARAMETER (MAXDEL=20) CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IODRD1(MAXDEL) CHARACTER*4 IODRD2(MAXDEL) CHARACTER*4 IODRD3(MAXDEL) CHARACTER*4 IODRD4(MAXDEL) CHARACTER*4 IWEIN1(MAXDEL) CHARACTER*4 IWEIN2(MAXDEL) CHARACTER*4 ICASOD CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C C C TWO CASES: C 1) DELTA WEIGHT VARIABLES C 2) DELTA STARTING POINT VARIABLES C IF(ICASOD.EQ.'DELT'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'WEIG')THEN C DO1010I=1,MAXDEL IODRD1(I)='OFF' IODRD2(I)=' ' 1010 CONTINUE C IF(IHARG(2).EQ.'OFF')GOTO1040 IF(NUMARG.GT.1)GOTO1110 IF(NUMARG.LE.1)GOTO1040 GOTO1060 C 1040 CONTINUE IODRD1(1)='OFF ' IODRD2(1)=' ' DO1045I=2,MAXDEL IODRD1(1)='OFF ' IODRD2(1)=' ' 1045 CONTINUE GOTO1080 C 1060 CONTINUE IODRD1(1)=IHARG(NUMARG) IODRD2(1)=IHARG2(NUMARG) GOTO1080 C 1080 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1089 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1081)IODRD1(1),IODRD2(2) 1081 FORMAT('THE ORTHOGONAL DISTANCE DELTA WEIGHT VARIABLE(S) HAS ', 1 'JUST BEEN DESIGNATED AS ', A4,A4) CALL DPWRST('XXX','BUG ') 1089 CONTINUE GOTO1199 C 1110 CONTINUE IFOUND='YES' IF(NUMARG.LT.2)GOTO1199 DO1115J=2,MIN(NUMARG,MAXDEL+1) JM1=J-1 IODRD1(JM1)=IHARG(J) IODRD2(JM1)=IHARG2(J) C IF(IFEEDB.EQ.'OFF')GOTO1115 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)JM1,IODRD1(JM1),IODRD2(JM1) 1181 FORMAT('THE ORTHOGONAL DISTANCE DELTA WEIGHT VARIABLE ',I4, 1 ' HAS JUST BEEN DESIGNATED AS ', A4,A4) CALL DPWRST('XXX','BUG ') 1115 CONTINUE GOTO1199 C 1199 CONTINUE C ELSEIF(ICASOD.EQ.'DELT')THEN C DO2010I=1,MAXDEL IODRD3(I)='OFF ' IODRD4(I)=' ' 2010 CONTINUE C IF(IHARG(1).EQ.'OFF')GOTO2040 GOTO2110 C 2040 CONTINUE DO2045I=1,MAXDEL IODRD3(1)='OFF ' IODRD4(1)=' ' 2045 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO2089 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2081)IODRD3(1),IODRD4(2) 2081 FORMAT('THE ORTHOGONAL DISTANCE DELTA STARTING VALUE ', 1 'VARIABLE(S) HAS ', 1 'JUST BEEN DESIGNATED AS ', A4,A4) CALL DPWRST('XXX','BUG ') 2089 CONTINUE GOTO2199 C 2110 CONTINUE IFOUND='YES' IF(NUMARG.LT.1)GOTO2199 DO2115J=1,MIN(MAXDEL,NUMARG) IODRD3(J)=IHARG(J) IODRD4(J)=IHARG2(J) C IF(IFEEDB.EQ.'OFF')GOTO2115 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2181)J,IODRD3(J),IODRD4(J) 2181 FORMAT('THE ORTHOGONAL DISTANCE DELTA STARTING VALUES ', 1 'VARIABLE ',I4,' HAS JUST BEEN DESIGNATED AS ', A4,A4) CALL DPWRST('XXX','BUG ') 2115 CONTINUE GOTO2199 C 2199 CONTINUE ELSEIF(ICASOD.EQ.'Y')THEN C DO4010I=1,MAXDEL IWEIN1(I)='OFF ' IWEIN2(I)=' ' 4010 CONTINUE C IF(IHARG(2).EQ.'OFF')GOTO4040 IF(NUMARG.GT.1)GOTO4110 IF(NUMARG.LE.1)GOTO4040 GOTO4060 C 4040 CONTINUE IWEIN1(1)='OFF ' IWEIN2(1)=' ' DO4045I=2,MAXDEL IWEIN1(1)='OFF ' IWEIN2(1)=' ' 4045 CONTINUE GOTO4080 C 4060 CONTINUE IWEIN1(1)=IHARG(NUMARG) IWEIN2(1)=IHARG2(NUMARG) GOTO4080 C 4080 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO4089 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4081)IWEIN1(1),IWEIN2(2) 4081 FORMAT('THE ORTHOGONAL DISTANCE Y WIEGHTS VARIABLE(S) HAS ', 1 'JUST BEEN DESIGNATED AS ', A4,A4) CALL DPWRST('XXX','BUG ') 4089 CONTINUE GOTO4199 C 4110 CONTINUE IFOUND='YES' IF(NUMARG.LT.2)GOTO4199 DO4115J=2,MIN(NUMARG,MAXDEL+1) JM1=J-1 IWEIN1(JM1)=IHARG(J) IWEIN2(JM1)=IHARG2(J) C IF(IFEEDB.EQ.'OFF')GOTO4115 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4181)JM1,IWEIN1(JM1),IWEIN2(JM1) 4181 FORMAT('THE ORTHOGONAL DISTANCE Y WEIGHTS VARIABLE ',I4, 1 ' HAS JUST BEEN DESIGNATED AS ', A4,A4) CALL DPWRST('XXX','BUG ') 4115 CONTINUE GOTO4199 C 4199 CONTINUE ENDIF RETURN END SUBROUTINE DPORER(IHARG,IHARG2,NUMARG, 1IODRE1,IODRE2,IFOUND,IERROR) C C PURPOSE--DEFINE THE USER VARIABLE NAME THAT DETERMINES WHICH C COLUMNS OF THE DESIGN MATRIX ARE TREATED AS C FIXED (I.E., NO ERRORS) OR HAVE ERRORS. THE C CHOICES ARE: C IODRE1 = 'ON': ALL COLUMNS HAVE ERRORS C IODRE1 = 'OFF': NO COLUMNS HAVE ERRORS (I.E., C STANDARD LEAST SQUARES WILL BE USED) C OTHERWISE, IODRE1 AND IODRE2 DEFINE A VARIABLE C THAT CONTAINS 0 (FOR NO ERRORS) OR 1 (FOR ERRORS). C THAT IS, THE FIRST ROW OF THE VARIABLE APPLIES TO C THE FIRST VARIABLE IN THE FIT, THE SECOND ROW OF THE C VARIABLE APPLLIES TO THE SECOND VARIABLE IN THE FIT, C ETC. NOTE THAT ODRPACK ACTUALLY ALLOWS EACH ELEMENT, C NOT JUST COLUMN, OF THE DESIGN MATRIX TO BE SET. C HOWEVER, DATAPLOT LIMITS THE CHOICE ON A COLUMN C BASIS. C NOTE: UPDATED TO ALLOW A LIST OF VARIABLE NAMES. C THIS ALLOWS THE DELTAS TO VE FIXED OR UNFIXED C AT THE OBSERVATION LEVEL AS OPPOSED TO THE C COLUMN LEVEL. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IHARG2 (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IODRE1 (A HOLLERITH VARIABLE) C --IODRE2 (A HOLLERITH VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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--2001/4 C ORIGINAL VERSION--APRIL 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C PARAMETER (MAXDEL=20) CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IODRE1(MAXDEL) CHARACTER*4 IODRE2(MAXDEL) CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1110 CONTINUE IF(NUMARG.LE.1)THEN IF(NUMARG.EQ.0)THEN DO1140I=1,MAXDEL IODRE1(I)='ON ' IODRE2(I)=' ' 1140 CONTINUE IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('THE ORTHOGONAL DISTANCE FIT WILL ASSUME ALL ', 1 'INDEPENDENT VARIABLES HAVE ERRORS.') CALL DPWRST('XXX','BUG ') ENDIF ELSEIF(IHARG(1).EQ.'ON' .OR. IHARG(1).EQ.'YES' .OR. 1 IHARG(1).EQ.'AUTO' .OR. IHARG(1).EQ.'DEFA')THEN IFOUND='YES' DO1150I=1,MAXDEL IODRE1(I)='ON ' IODRE2(I)=' ' 1150 CONTINUE IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('THE ORTHOGONAL DISTANCE FIT WILL ASSUME ALL ', 1 'INDEPENDENT VARIABLES HAVE ERRORS.') CALL DPWRST('XXX','BUG ') ENDIF ELSEIF(IHARG(1).EQ.'OFF' .OR. IHARG(1).EQ.'NO' .OR. 1 IHARG(1).EQ.'NONE')THEN IFOUND='YES' DO1170I=1,MAXDEL IODRE1(I)='OFF ' IODRE2(I)=' ' 1170 CONTINUE IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1171) 1171 FORMAT('THE ORTHOGONAL DISTANCE FIT WILL ASSUME ALL ', 1 'INDEPENDENT VARIABLES ARE FIXED.') CALL DPWRST('XXX','BUG ') ENDIF ELSE IFOUND='YES' IODRE1(1)=IHARG(1) IODRE2(1)=IHARG2(1) IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IODRE1(1),IODRE2(2) 1181 FORMAT('THE VARIABLE ',A4,A4,' WILL DEFINE WHICH ', 1 'INDEPENDENT VARIABLES ARE FIXED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1183) 1183 FORMAT('AND WHICH ARE ASSUMED TO HAVE ERRORS IN ', 1 'ORTHOGONAL DISTANCE FITS.') CALL DPWRST('XXX','BUG ') ENDIF ENDIF ELSEIF(NUMARG.GT.1)THEN IFOUND='YES' C DO3010I=1,MAXDEL IODRE1(I)='OFF ' IODRE2(I)=' ' 3010 CONTINUE C DO3115J=1,MIN(NUMARG,MAXDEL) IODRE1(J)=IHARG(J) IODRE2(J)=IHARG2(J) C IF(IFEEDB.EQ.'OFF')GOTO3115 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3181)J,IODRE1(J),IODRE2(J) 3181 FORMAT('THE ORTHOGONAL DISTANCE FIXED VARIABLE ',I4, 1 ' HAS JUST BEEN DESIGNATED AS ', A4,A4) CALL DPWRST('XXX','BUG ') 3115 CONTINUE GOTO3199 C 3199 CONTINUE ENDIF C 1199 CONTINUE RETURN END SUBROUTINE DPORSW(IHARG,NUMARG,IFOUND,IERROR) C C PURPOSE--DEFINE THE ORIENTATION SWITCH IORNSW C (DETERMINES PAGE ORIENTATION. FOR EXAMPLE, C POSTSCRIPT, QUIC AND OTHER LASER PRINTERS TYPICALLY C SUPPORT A "PORTRAIT" AND "LANDSCAPE" MODE. ALSO INCLUDE C "POSTER" MODE FOR CALCOMP TYPE PLOTTERS THAT CAN SUPPORT C A "LARGE" PAPER SIZE. C FOR POSTSCRIPT, ADD "LANDSCAPE WORDPERFECT" OPTION. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES 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 THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C UPADATED --MARCH 1990. (ADDED SQUARE OPTION, ALAN) C UPADATED --NOVEMBER 1996. ADD "LANDSCAPE WORDPERFECT" C UPADATED --MARCH 2006. BUG FIX: GRSEPP AUTOMATICALLY C TURNS DEVICE ON, SO DON'T C CALL GRSEPP IF DEVICE IS OFF. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IFOUND CHARACTER*4 IFOUN2 CHARACTER*4 IERROR CCCCC CHARACTER*4 IPOWER CHARACTER*4 IBUGO2 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOST.INC' INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOF2.INC' 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' IBUGO2='OFF' C IF(NUMARG.LT.1)GOTO1199 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'SQUA')GOTO1140 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IHARG(NUMARG).EQ.'FULL')GOTO1150 IF(IHARG(NUMARG).EQ.'MAXI')GOTO1150 IF(IHARG(NUMARG).EQ.'LAND')GOTO1160 IF(IHARG(NUMARG).EQ.'HORI')GOTO1160 IF(IHARG(NUMARG).EQ.'VERT')GOTO1170 IF(IHARG(NUMARG).EQ.'PORT')GOTO1170 IF(IHARG(NUMARG).EQ.'POST')GOTO1175 CCCCC ADD FOLLOWING LINE FOR LANDSCAPE WORDPERFECT, NOVEMBER 1996. IF(IHARG(NUMARG).EQ.'WORD')GOTO1178 GOTO1199 C 1140 CONTINUE IORNSW='SQUA' GOTO1180 C 1150 CONTINUE IORNSW='FULL' GOTO1180 C 1160 CONTINUE IORNSW='LAND' GOTO1180 C 1170 CONTINUE IORNSW='PORT' GOTO1180 C 1175 CONTINUE IORNSW='POST' GOTO1180 C 1178 CONTINUE IORNSW='LAN2' GOTO1180 C 1180 CONTINUE IFOUND='YES' C C ******************************************** C ** STEP 20-- ** C ** CALL GRSEPP FOR EACH DEVICE ** C ******************************************** C DO2000IDEV=1,NUMDEV C C MARCH 2006 BUG FIX: ONLY CALL GRSEPP IF DEVICE IS ON. C IF(IDPOWE(IDEV).NE.'ON')GOTO2000 C IFOUN2='NO' CALL GRSEPP(IDEV, 1IPL1NU, 1IPL2NU, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, 1IBUGO2,IFOUN2,IERROR) 2000 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IORNSW 1181 FORMAT('THE ORIENTATION SWITCH HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182) 1182 FORMAT('NOTE: THE EFFECT OF THIS COMMAND IS DEVICE DEPENDENT') CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPORTH(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1IFOUND,IERROR) C C PURPOSE--CARRY OUT AN ORTHOGONAL DISTANCE (ERROR IN VARIABLES) C FIT (BASED ON ODRPACK CODE) C FOR LINEAR AND NON-LINEAR MODELS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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--2001/4 C ORIGINAL VERSION--APRIL 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C PARAMETER (MAXDEL=20) C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASFI CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 ICASEQ CHARACTER*4 IKEY CHARACTER*4 IWD1 CHARACTER*4 IWD2 CHARACTER*4 IWD12 CHARACTER*4 IWD22 CHARACTER*4 IHPARN CHARACTER*4 IHPAR2 CHARACTER*4 IREPU CHARACTER*4 IRESU CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHRESP(MAXDEL) CHARACTER*4 IHRES2(MAXDEL) CHARACTER*4 IREP CHARACTER*4 IMPFLG CHARACTER*4 CTEMP1 CHARACTER*4 CTEMP2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IPART1 CHARACTER*4 IPART2 C DIMENSION IPART1(100) DIMENSION IPART2(100) DIMENSION PARTMP(100) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHO.INC' C PARAMETER (MAXFAC=20) PARAMETER (MAXOB2=MAXOBV/2) C DIMENSION IPAROC(100) C REAL RES2(MAXOB2) REAL PRED2(MAXOB2) DOUBLE PRECISION W(MAXOB2) DOUBLE PRECISION YTEMP(MAXOB2) C DOUBLE PRECISION XMAT(10*MAXOBV) DOUBLE PRECISION RHO(20*MAXOBV/2) DOUBLE PRECISION WORK(46*MAXOBV/2) C DIMENSION PARAM3(100) DIMENSION ICOLV3(100) DIMENSION NIV(100) C INTEGER IFIX(MAXOB2*MAXDEL) INTEGER IWORK(MAXOBV) DIMENSION ILOCD(MAXDEL) DIMENSION ICOLD(MAXDEL) DIMENSION NDELTA(MAXDEL) DIMENSION ILOCD2(MAXDEL) DIMENSION ICOLD2(MAXDEL) DIMENSION NDELT2(MAXDEL) DIMENSION ILOCRV(MAXDEL) DIMENSION ICOLRV(MAXDEL) DIMENSION ILOCWR(MAXDEL) DIMENSION ICOLWR(MAXDEL) DIMENSION NRWEIG(MAXDEL) DIMENSION ILOCE(MAXDEL) DIMENSION ICOLE(MAXDEL) DIMENSION NERROR(MAXDEL) CHARACTER*4 IDLFLG C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOST.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C EQUIVALENCE (W(1),X3D(1)) EQUIVALENCE (PRED2(1),X(1)) EQUIVALENCE (RES2(1),D(1)) EQUIVALENCE (YTEMP(1),Y(1)) C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' INCLUDE 'DPCOZD.INC' INCLUDE 'DPCOZI.INC' EQUIVALENCE (GARBAG(IGARB1),RHO(1)) EQUIVALENCE (G2RBAG(IGAR11),WORK(1)) EQUIVALENCE (DGARBG(IDGAR1),XMAT(1)) EQUIVALENCE (IGARBG(IIGAR1),IFIX(1)) EQUIVALENCE (IGARBG(IIGR17),IWORK(1)) C PARAMETER (IODRCH=1000) PARAMETER (IODRC2=100) PARAMETER (MAXNQ=5) C CHARACTER*4 IBUGAZ CHARACTER*4 ZTYPEH CHARACTER*4 ZW21HO CHARACTER*4 ZW22HO CHARACTER*4 ZIPARN CHARACTER*4 ZPARN2 CHARACTER*4 ZMODEL CHARACTER*4 ZIDUMV CHARACTER*4 ZDUMV2 C DIMENSION ZPARAM(IODRC2,MAXNQ) DIMENSION ZIPARN(IODRC2,MAXNQ) DIMENSION ZPARN2(IODRC2,MAXNQ) DIMENSION ZIDUMV(IODRC2,MAXNQ) DIMENSION ZDUMV2(IODRC2,MAXNQ) DIMENSION LOCDUM(IODRC2,MAXNQ) C DIMENSION ZMODEL(IODRCH,MAXNQ) DIMENSION ZTYPEH(IODRCH,MAXNQ) DIMENSION ZW21HO(IODRCH,MAXNQ) DIMENSION ZW22HO(IODRCH,MAXNQ) DIMENSION Z2HOLD(IODRCH,MAXNQ) C INTEGER NUMCHZ(MAXNQ) INTEGER NUMPAZ(MAXNQ) INTEGER NWHOLZ(MAXNQ) INTEGER NUMVAZ(MAXNQ) C COMMON /ODRCMC/ IBUGAZ, ZTYPEH, ZW21HO, ZW22HO, ZIPARN, ZPARN2, & ZIDUMV, ZDUMV2, ZMODEL COMMON /ODRCMR/ ZPARAM, Z2HOLD, & NUMCHZ, NUMPAZ, NWHOLZ, NUMVAZ, LOCDUM C CHARACTER*4 IPAROC CHARACTER*4 IPARO3 CHARACTER*4 IPARN3 CHARACTER*4 IPARN4 CHARACTER*4 IVARN3 CHARACTER*4 IVARN4 DIMENSION IPARN3(100) DIMENSION IPARN4(100) DIMENSION ICON3(100) DIMENSION IPARO3(100) DIMENSION PARLI3(100) DIMENSION IVARN3(100) DIMENSION IVARN4(100) C COMMON /ODRCM2/ IPAROC, IPARO3, IPARN3, IPARN4, IVARN3, IVARN4 COMMON /ODRCR2/ ICON3, PARLI3, NUMPAR, NUMVAR C C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPOR' ISUBN2='TH ' C IERROR='NO' IMPFLG='OFF' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IPAROC(1)='NONE' C MAXV2=MAXDEL MAXYV2=5 MINN2=2 NQ=1 C MAXITS=IFITIT C MAXN2=MAXCHF MAXN3=MAXCHF MAXN4=MAXCHF C NUMPV=(-999) IP=(-999) IV=(-999) C IWIDMO=(-999) C NUMIND=(-999) C C ************************** C ** TREAT THE FIT CASE ** C ************************** C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'ORTH')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPORTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA2,IBUGA3 53 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMNAM 56 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO57I=1,NUMNAM WRITE(ICOUT,58)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 58 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 57 CONTINUE 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICOM.EQ.'ORTH'.AND.IHARG(1).EQ.'DIST'.AND. 1 IHARG(2).EQ.'FIT ')GOTO112 IF(ICOM.EQ.'ORTH'.AND.IHARG(1).EQ.'DIST'.AND. 1 IHARG(2).EQ.'REGR')GOTO112 IF(ICOM.EQ.'ERRO'.AND.IHARG(1).EQ.'IN '.AND. 1 IHARG(2).EQ.'VARI'.AND.IHARG(3).EQ.'FIT ')GOTO113 IF(ICOM.EQ.'ERRO'.AND.IHARG(1).EQ.'IN '.AND. 1 IHARG(2).EQ.'VARI'.AND.IHARG(3).EQ.'REGR')GOTO113 IFOUND='NO' GOTO9000 C 112 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 113 CONTINUE ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' ICASFI='ORTF' C IF(ICASFI.EQ.' '.OR.IFOUND.EQ.'NO')GOTO9000 C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=0 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ****************************************************** C ** STEP 3-- ** C ** FOR THE CASES WHEN HAVE FIT Y = SOME EXPRESSION ** C ** DETERMINE IF WE HAVE A VALID FUNCTIONAL ** C ** EXPRESSION--IN PARTICULAR, CHECK THAT THE NUMBER** C ** OF ARGUMENTS IS AT LEAST 1, AND ALSO CHECK ** C ** THAT THERE IS EXACTLY 1 EQUAL SIGN AND THAT ** C ** THIS EQUAL SIGN OCCURS AS THE SECOND ARGUMENT. ** C ****************************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.1)GOTO2090 WRITE(ICOUT,2001) 2001 FORMAT('***** ERROR IN DPORTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2002) 2002 FORMAT(' NUMBER OF ARGUMENTS DETECTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2003)NUMARG 2003 FORMAT(' IN ORTHOGONAL DISTANCE FIT COMMAND = 0. ', 1 'NUMARG = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2007)IWIDTH 2007 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH)) 2008 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2090 CONTINUE C 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.' ')GOTO2110 2100 CONTINUE ILOCQ=NUMARG+1 GOTO2120 2110 CONTINUE ILOCQ=J1 GOTO2120 2120 CONTINUE C IF(ICASFI.EQ.'ORTF')GOTO2125 GOTO2190 2125 CONTINUE NUMEQ=0 IMAX=ILOCQ-1 DO2130I=1,IMAX IF(IHARG(I).EQ.'= '.AND.IHARG2(I).EQ.' ')THEN NUMEQ=NUMEQ+1 NQ=I-1 ILOCE2=I ENDIF 2130 CONTINUE IF(NUMEQ.GT.1)THEN WRITE(ICOUT,2131) 2131 FORMAT('***** ERROR IN DPORTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2132) 2132 FORMAT(' NUMBER OF EQUAL SIGNS DETECTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2133)NUMEQ 2133 FORMAT(' IN MODEL GREATER THAN 1. NUMEQ = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2134)NUMARG,IMAX 2134 FORMAT(' NUMARG, IMAX = ',2I10) CALL DPWRST('XXX','BUG ') DO2135I=1,NUMARG WRITE(ICOUT,2136)I,IHARG(I),IHARG2(I) 2136 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,A4,A4) CALL DPWRST('XXX','BUG ') 2135 CONTINUE WRITE(ICOUT,2137)IWIDTH 2137 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2138)(IANS(J),J=1,IWIDTH) 2138 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ELSEIF(NUMEQ.EQ.0)THEN IMPFLG='ON' ENDIF IF(NQ.GT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2141) 2141 FORMAT('FOR ORTHOGONAL DISTANCE FIT, MULTIPLE RESPONSE ', 1 'VARIABLES CASE DETECTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2143)NQ 2143 FORMAT('NUMBER OF RESPONSE VARIABLES = ',I5) CALL DPWRST('XXX','BUG ') IF(NQ.GT.MAXDEL)THEN WRITE(ICOUT,2145)MAXDEL 2145 FORMAT('**** ERROR: MAXIMIUM NUMBER OF RESPONSE VARIABLES,', 1 I5,', EXCEEDED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF ENDIF C 2190 CONTINUE C IF(ICASFI.EQ.'ORTF'.AND.IHARG(2).NE.'='.AND. 1 NQ.EQ.1.AND.IMPFLG.EQ.'OFF')GOTO2200 GOTO2290 C 2200 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2201) 2201 FORMAT('***** ERROR IN DPORTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2202) 2202 FORMAT(' WHEN FITTING GENERAL EXPRESSIONS,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2203) 2203 FORMAT(' THE SECOND ARGUMENT AFTER THE WORD FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2204) 2204 FORMAT(' SHOULD BE (BUT WAS NOT) AN EQUAL SIGN.') CALL DPWRST('XXX','BUG ') IF(ICASFI.EQ.'ORTF')THEN WRITE(ICOUT,2205)IHARG(2),IHARG2(2) 2205 FORMAT(' THE ARGUMENT WAS ',A4,A4) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,2207)IWIDTH 2207 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2208)(IANS(J),J=1,MIN(100,IWIDTH)) 2208 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 2290 CONTINUE C C **************************************************** C ** STEP 4-- ** C ** FOR ALL VARIATIONS OF THE COMMAND, ** C ** THE WORD AFTER FIT SHOULD BE THE RESPONSE ** C ** VARIABLE (= THE DEPENDENT VARIABLE). ** C ** EXTRACT THE RESPONSE VARIABLE AND DETERMINE ** C ** IF IT IS ALREADY IN THE NAME LIST AND IS, IN ** C ** FACT, A VARIABLE (AS OPPOSED TO A PARAMETER). ** C ** NOTE: FOR IMPLICIT MODEL, NO RESPONSE ** C ** VARIABLE. ** C **************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IMPFLG.EQ.'ON')THEN I2=0 NLEFT=-1 IHLEFT=' ' IHLEF2=' ' GOTO2390 ENDIF C I2=0 C ILOCFI=I2 C DO2310J=1,NQ ILOCF1=ILOCFI+1 IF(J.EQ.1)THEN IHLEFT=IHARG(ILOCF1) IHLEF2=IHARG2(ILOCF1) ENDIF IHRESP(J)=IHARG(ILOCF1) IHRES2(J)=IHARG2(ILOCF1) DO2350I=1,NUMNAM I2=I IF(IHRESP(J).EQ.IHNAME(I2).AND.IHRES2(J).EQ.IHNAM2(I2).AND. 1 IUSE(I2).EQ.'V')GOTO2379 2350 CONTINUE WRITE(ICOUT,2361) 2361 FORMAT('***** ERROR IN DPORTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2362) 2362 FORMAT(' A NAME BETWEEN THE WORD FIT AND THE "=" SIGN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2363) 2363 FORMAT(' (WHICH SHOULD BE A RESPONSE VARIABLE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2364) 2364 FORMAT(' EITHER DOES NOT EXIST OR IS A PARAMETER ', 1 '(AS OPPOSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2366) 2366 FORMAT(' TO A VARIABLE) IN THE CURRENT LIST OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2367) 2367 FORMAT(' AVAILABLE VARIABLE AND PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2369)IHRESP(J),IHRES2(J) 2369 FORMAT(' NAME AFTER THE WORD FIT = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) 2378 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2379 CONTINUE IF(J.EQ.1)THEN ILOCV=I2 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) ELSE ILOCRV(J)=I2 ICOLRV(J)=IVALUE(ILOCV) NTEMP=IN(ILOCV) IF(NTEMP.NE.NLEFT)THEN WRITE(ICOUT,2381) 2381 FORMAT('***** ERROR IN DPORTH--FOR THE MULTI-RESPONSE', 1 'VARIABLE CASE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2383) 2383 FORMAT(' ALL RESPONSE VARIABLES MUST HAVE THE SAME', 1 'NUMBER OF OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2385)IHRESP(J),IHRES2(J),NTEMP 2385 FORMAT(' RESPONSE VARIABLE ',A4,A4,' HAS ',I8, 1 'OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2387)NLEFT 2387 FORMAT(' NUMBER OF OBSEVATIONS EXPECTED: ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF 2310 CONTINUE C 2390 CONTINUE C C **************************************************** C ** STEP 5-- ** C ** FOR ALL VARIATIONS OF THE COMMAND, CHECK THAT ** C ** THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER AND ** C ** LESS THAN MAXOB2. ** C **************************************************** C ISTEPN='5' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IMPFLG.EQ.'ON')GOTO390 IF(NLEFT.GE.MINN2.AND.NLEFT.LE.MAXOB2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPORTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS (FOR WHICH AN ', 1'(IN VARIABLE ',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' ORTHOGONAL DISTANCE FIT WAS TO HAVE BEEN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' PERFORMED MUST BE AT LEAST ',I8,' AND NO MORE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' THAN ',I8,'; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317)NLEFT 317 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,318) 318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,319)(IANS(I),I=1,MIN(100,IWIDTH)) 319 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 390 CONTINUE C C ************************************************ C ** STEP 5.1-- ** C ** CHECK TO SEE IF HAVE A WEIGHTS VARIABLE. ** C ** IF DO HAVE, CHECK TO SEE IF A VARIABLE ** C ** (AS OPPOSED TO A PARAMETER). ** C ** NOTE: TWO WAYS TO DEFINE WEIGHT VARIABLES:** C ** 1) WEIGHTS COMMAND - FOR SINGLE ** C ** RESPONSE CASE ONLY. ** C ** 2) ORTOGONAL DISTANCE Y WEIGHTS - FOR ** C ** EITHER SINGLE RESPONSE OR ** C ** MULTI-RESPONSE CASES. ** C ** NOTE THAT IF BOTH SPECIFIED FOR SINGLE ** C ** RESPONSE CASE, THEN METHOD 2 OVERRIDES. ** C ************************************************ C ISTEPN='5.1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCW=-99 ICOLW=-99 NWEIGH=-99 DO2405I=1,MAXDEL ILOCWR(I)=-99 ICOLWR(I)=-99 NRWEIG(I)=-99 2405 CONTINUE C IF(IMPFLG.EQ.'ON')GOTO2490 IF(IWEIGH.EQ.'OFF'.AND.IWEIN1(1).EQ.'OFF')GOTO2490 C IF(NQ.EQ.1.AND.J.EQ.1 .AND. IWEIN1(1).EQ.'OFF')THEN CTEMP1=IWEIG1 CTEMP2=IWEIG2 DO2420I=1,NUMNAM I2=I IF(IWEIG1.EQ.IHNAME(I2).AND.IWEIG2.EQ.IHNAM2(I2).AND. 1 IUSE(I2).EQ.'V')THEN ILOCW=I2 ICOLW=IVALUE(ILOCW) NWEIGH=IN(ILOCW) ILOCWR(1)=ILOCW ICOLWR(1)=ICOLW NRWEIG(1)=NWEIGH IF(NWEIGH.NE.NLEFT)GOTO2481 GOTO2490 ENDIF 2420 CONTINUE GOTO2460 ENDIF C DO2410J=1,NQ C CTEMP1=IWEIN1(J) CTEMP2=IWEIN2(J) DO2450I=1,NUMNAM I2=I IF(IWEIN1(J).EQ.IHNAME(I2).AND.IWEIN2(J).EQ.IHNAM2(I2).AND. 1 IUSE(I2).EQ.'V')THEN ILOCWR(J)=I2 ICOLWR(J)=IVALUE(ILOCWR(J)) NRWEIG(J)=IN(ILOCWR(J)) IF(NRWEIG(J).NE.NLEFT)GOTO2481 GOTO2490 ENDIF 2450 CONTINUE C 2410 CONTINUE C 2460 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2461) 2461 FORMAT('***** ERROR IN DPORTH--A WEIGHT VARIABLE FOR THE', 1 ' RESPONSE VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2463) 2463 FORMAT(' (AS SPECIFIED VIA THE WEIGHTS COMMAND OR THE ', 1 'ORTHOGONAL DISTANCE Y WEIGHTS COMMAND)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2465) 2465 FORMAT(' EITHER DOES NOT EXIST OR IS A PARAMETER (AS ', 1 'OPPOSED TO A VARIABLE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2466) 2466 FORMAT(' IN THE CURRENT LIST OF AVAILABLE VARIABLE AND ', 1 'PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2469)CTEMP1,CTEMP2 2469 FORMAT(' NAME OF SPECIFIED WEIGHTS VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2478)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) 2478 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 2481 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2483) 2483 FORMAT('***** ERROR IN DPORTH--A WEIGHT VARIABLE FOR THE', 1 ' RESPONSE VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2485) 2485 FORMAT(' DOES NOT HAVE THE SAME NUMBER OF OBSERVATIONS ', 1 'AS THE RESPONSE VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2487)CTEMP1,CTEMP2,NRWEIG(J) 2487 FORMAT(' WEIGHT VARIABLE, ',A4,A4,' HAS ',I8, 1 'OBSEVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2489)NLEFT 2489 FORMAT(' NUMBER OF OBSEVATIONS EXPECTED: ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2478)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 2490 CONTINUE C C ************************************************ C ** STEP 5.2-- ** C ** CHECK TO SEE IF HAVE A "ERROR" VARIABLE. ** C ** IF DO HAVE, CHECK TO SEE IF A VARIABLE ** C ** (AS OPPOSED TO A PARAMETER). ** C ************************************************ C ISTEPN='5.2' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2510I=1,MAXDEL ILOCE(I)=-99 ICOLE(I)=-99 NERROR(I)=-99 2510 CONTINUE NUMERR=0 C IF(IODRE1(1).EQ.'ON')THEN CONTINUE ELSEIF(IODRE1(1).NE.'OFF')THEN DO2540J=1,MAXDEL IF(IODRE1(J).EQ.'OFF' .OR. IODRE1(J).EQ.'ON')GOTO2549 DO2550I=1,NUMNAM I2=I IF(IODRE1(J).EQ.IHNAME(I2).AND.IODRE2(J).EQ.IHNAM2(I2).AND. 1 IUSE(I2).EQ.'V')GOTO2579 2550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2561) 2561 FORMAT('***** ERROR IN DPORTH--ONE OF THE ERRORS VARIABLE ', 1 '(AS SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2563) 2563 FORMAT(' VIA THE ORTHOGONAL DISTANCE ERROR COMMAND) ', 1 'EITHER DOES NOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2565) 2565 FORMAT(' EXIST OR IS A PARAMETER (AS OPPOSED TO A', 1 ' VARIABLE) IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2566) 2566 FORMAT(' THE CURRENT LIST OF AVAILABLE ', 1 'VARIABLE AND PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2569)IODRE1(J),IODRE2(J) 2569 FORMAT(' NAME OF SPECIFIED ERRORS VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2578)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) 2578 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2579 CONTINUE NUMERR=NUMERR+1 ILOCE(J)=I2 ICOLE(J)=IVALUE(ILOCE(J)) NERROR(J)=IN(ILOCE(J)) C 2540 CONTINUE 2549 CONTINUE ENDIF C 2599 CONTINUE C C ************************************************ C ** STEP 5.3-- ** C ** CHECK TO SEE IF HAVE ONE OR MORE DELTA ** C ** WEIGHT VARIABLE(S). ** C ** IF DO HAVE, CHECK TO SEE IF A VARIABLE ** C ** (AS OPPOSED TO A PARAMETER). ** C ************************************************ C ISTEPN='5.3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IDLFLG='OFF' NUMDEL=0 C DO2610I=1,MAXDEL ILOCD(I)=-99 ICOLD(I)=-99 NDELTA(I)=-99 2610 CONTINUE C IF(IODRD1(1).EQ.'OFF')GOTO2699 IF(IODRD1(1).EQ.'ON')THEN IDLFLG='DEFA' ELSEIF(IODRD1(1).NE.'OFF')THEN DO2640J=1,MAXDEL IF(IODRD1(J).EQ.'OFF')GOTO2649 DO2650I=1,NUMNAM I2=I IF(IODRD1(J).EQ.IHNAME(I2).AND.IODRD2(J).EQ.IHNAM2(I2).AND. 1 IUSE(I2).EQ.'V')GOTO2679 2650 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2661) 2661 FORMAT('***** ERROR IN DPORTH--ONE OF THE DELTA WEIGHT VARIABLES', 1 ' (AS SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2663) 2663 FORMAT(' VIA THE ORTHOGONAL DISTANCE DELTA COMMAND) EITHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2665) 2665 FORMAT(' DOES NOT EXIST OR IS A PARAMETER (AS OPPOSED TO A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2666) 2666 FORMAT(' VARIABLE) IN THE CURRENT LIST OF AVAILABLE ', 1 'VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2667) 2667 FORMAT(' AND PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2669)IODRD1(J),IODRD2(J) 2669 FORMAT(' NAME OF SPECIFIED ERRORS VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2678)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) 2678 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2679 CONTINUE NUMDEL=NUMDEL+1 ILOCD(J)=I2 ICOLD(J)=IVALUE(ILOCD(J)) NDELTA(J)=IN(ILOCD(J)) 2640 CONTINUE 2649 CONTINUE ENDIF C 2699 CONTINUE C C ************************************************ C ** STEP 5.4-- ** C ** CHECK TO SEE IF HAVE ONE OR MORE DELTA ** C ** STARTING VALUE VARIABLE(S). ** C ** IF DO HAVE, CHECK TO SEE IF A VARIABLE ** C ** (AS OPPOSED TO A PARAMETER). ** C ************************************************ C ISTEPN='5.4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C DO2710I=1,MAXDEL ILOCD2(I)=-99 ICOLD2(I)=-99 NDELT2(I)=-99 2710 CONTINUE NUMDE2=0 C IF(IODRD3(1).EQ.'OFF')GOTO2799 IF(IODRD3(1).EQ.'ON')GOTO2799 DO2740J=1,MAXDEL IF(IODRD3(J).EQ.'OFF')GOTO2749 DO2750I=1,NUMNAM I2=I IF(IODRD3(J).EQ.IHNAME(I2).AND.IODRD4(J).EQ.IHNAM2(I2).AND. 1 IUSE(I2).EQ.'V')GOTO2779 2750 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2761) 2761 FORMAT('***** ERROR IN DPORTH--ONE OF THE DELTA STARTING VALUE', 1 'VARIABLES (AS SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2763) 2763 FORMAT(' VIA THE ORTHOGONAL DISTANCE DELTA COMMAND) EITHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2765) 2765 FORMAT(' DOES NOT EXIST OR IS A PARAMETER (AS OPPOSED TO A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2766) 2766 FORMAT(' VARIABLE) IN THE CURRENT LIST OF AVAILABLE ', 1 'VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2767) 2767 FORMAT(' AND PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2769)IODRD3(J),IODRD4(J) 2769 FORMAT(' NAME OF SPECIFIED ERRORS VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2778)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) 2778 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2779 CONTINUE NUMDE2=NUMDE2+1 ILOCD2(J)=I2 ICOLD2(J)=IVALUE(ILOCD2(J)) NDELT2(J)=IN(ILOCD2(J)) 2740 CONTINUE 2749 CONTINUE C 2799 CONTINUE C C ****************************************************** C ** STEP 6.1-- ** C ** FOR THE CASES WHEN HAVE FIT Y = SOME EXPRESSION ** C ** EXTRACT THE ENTIRE (LEFT AND RIGHT SIDE) FUNCTIONAL C ** EXPRESSION FROM THE INPUT COMMAND LINE. ** C ** COPY OUT TO IWIDTH, OR OUT TO 'SUBS' (EXCLUSIVE),* C ** OR OUT THE 'EXCE' (EXCLUSIVE) ** C ** FIRST, FOR MULTI-RESPONSE CASE, CHECK THAT ** C ** HAVE A LIST OF NQ FUNCTION NAMES ON RHS. ** C ****************************************************** C ISTEPN='6.1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NQ.GT.1)THEN ISTRT=ILOCE2+1 ILAST=ILOCQ-1 NUMF=0 DO3010I=ISTRT,ILAST DO3020J=1,NUMNAM IF(IHARG(I).EQ.IHNAME(J).AND.IHARG2(I).EQ.IHNAM2(J))THEN IF(IUSE(J).EQ.'F')THEN NUMF=NUMF+1 GOTO3010 ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3021)IHARG(I),IHARG2(I) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3023) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3023) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF 3020 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3011)IHARG(I),IHARG2(I) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3013) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 3010 CONTINUE C IF(NQ.NE.NUMF)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3031) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3033) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3035) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3037)NUMF CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3039)NQ CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C DO3040L=1,NQ C ISTRT=ILOCE2+1 LL=L+ISTRT-1 DO3041II=1,4 IFUNC2(II)=IHARG(LL)(II:II) IFUNC2(II+4)=IHARG2(LL)(II:II) 3041 CONTINUE N2=8 C CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1 NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3, 1 IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C J=0 DO3050I=1,N3 J=J+1 ZMODEL(I,L)=IFUNC3(I) 3050 CONTINUE NUMCHZ(L)=J 3040 CONTINUE GOTO4190 ENDIF C 3011 FORMAT('***** ERROR IN DPORTH--FOR THE MULTI-RESPONSE CASE, ', 1 'ARGUMENT ',A4,A4) 3013 FORMAT(' WAS NOT FOUND IN THE CURRENT LIST OF AVAILABLE ', 1 'NAMES.') C 3021 FORMAT('***** ERROR IN DPORTH--FOR THE MULTI-RESPONSE CASE, ', 1 'ARGUMENT ',A4,A4) 3023 FORMAT(' WAS FOUND IN THE CURRENT LIST OF AVAILABLE ', 1 'NAMES. HOWEVER, IT WAS EXPECTED') 3025 FORMAT(' TO BE THE NAME OF A FUNTCION AND IT IS NOT.') C 3031 FORMAT('***** ERROR IN DPORTH--FOR THE MULTI-RESPONSE CASE, ', 1 'THE NUMBER OF FUNCTION') 3033 FORMAT(' NAMES ON THE RIGHT OF THE EQUAL SIGN MUST EQUAL ', 1 'THE NUMBER OF RESPONSE') 3035 FORMAT(' VARIABLES ON THE LEFT OF THE EQUAL SIGN.') 3037 FORMAT(' NUMBER OF FUNCTION NAMES = ',I5) 3039 FORMAT(' NUMBER OF RESPONSE VARIABLES = ',I5) C IF(ICASFI.EQ.'ORTF')GOTO4100 GOTO4190 4100 CONTINUE IF(NUMARG.EQ.0)GOTO4160 IF(IHARG(1).EQ.'SUBS'.AND.IHARG2(1).EQ.'ET ')GOTO4160 IF(IHARG(1).EQ.'EXCE'.AND.IHARG2(1).EQ.'PT ')GOTO4160 IF(IHARG(1).EQ.'FOR '.AND.IHARG2(1).EQ.' ')GOTO4160 ISTART=-99 ISTOP=-99 DO4110I=1,IWIDTH IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 IP6=I+6 IP7=I+7 IP8=I+8 IP9=I+9 IP10=I+10 C IF(IP2.GT.IWIDTH)GOTO4120 IF(IANS(I).EQ.'F'.AND.IANS(IP1).EQ.'I' 1 .AND.IANS(IP2).EQ.'T')THEN ISTART=IP3 IWD1='FIT ' IWD12=' ' GOTO4101 ENDIF C IF(IP9.GT.IWIDTH)GOTO4102 IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND. 1 IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND. 1 IANS(IP5).EQ.'S'.AND.IANS(IP6).EQ.'S'.AND. 1 IANS(IP7).EQ.'I'.AND.IANS(IP8).EQ.'O'.AND. 1 IANS(IP9).EQ.' ')THEN ISTART=IP9 IWD1='REGR' IWD12='ESSI' GOTO4101 ENDIF 4102 CONTINUE IF(IP8.GT.IWIDTH)GOTO4103 IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND. 1 IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND. 1 IANS(IP5).EQ.'S'.AND.IANS(IP6).EQ.'S'.AND. 1 IANS(IP7).EQ.'I'.AND.IANS(IP8).EQ.' ')THEN ISTART=IP8 IWD1='REGR' IWD12='ESS ' GOTO4101 ENDIF 4103 CONTINUE IF(IP7.GT.IWIDTH)GOTO4104 IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND. 1 IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND. 1 IANS(IP5).EQ.'S'.AND.IANS(IP6).EQ.'S'.AND. 1 IANS(IP7).EQ.' ')THEN ISTART=IP7 IWD1='REGR' IWD12='ES ' GOTO4101 ENDIF 4104 CONTINUE IF(IP6.GT.IWIDTH)GOTO4105 IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND. 1 IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND. 1 IANS(IP5).EQ.'S'.AND.IANS(IP6).EQ.' ')THEN ISTART=IP6 IWD1='REGR' IWD12='E ' GOTO4101 ENDIF 4105 CONTINUE IF(IP5.GT.IWIDTH)GOTO4106 IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND. 1 IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.'E'.AND. 1 IANS(IP5).EQ.' ')THEN ISTART=IP5 IWD1='REGR' IWD12=' ' GOTO4101 ENDIF 4106 CONTINUE IF(IP4.GT.IWIDTH)GOTO4107 IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'E'.AND.IANS(IP2).EQ.'G'.AND. 1 IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.' ')THEN ISTART=IP4 GOTO4101 ENDIF 4107 CONTINUE C 4101 CONTINUE C IF(IP4.GT.IWIDTH)GOTO4108 IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'F'. 1 AND.IANS(IP2).EQ.'O'.AND.IANS(IP3).EQ.'R'. 1 AND.IANS(IP4).EQ.' ')ISTOP=I 4108 CONTINUE C IF(IP7.GT.IWIDTH)GOTO4110 IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'S'. 1 AND.IANS(IP2).EQ.'U'.AND.IANS(IP3).EQ.'B'. 1 AND.IANS(IP4).EQ.'S'.AND.IANS(IP5).EQ.'E'. 1 AND.IANS(IP6).EQ.'T'.AND.IANS(IP7).EQ.' ')ISTOP=I C 4110 CONTINUE 4120 CONTINUE C IF(ISTART.GE.1)GOTO4129 IBRAN=4120 WRITE(ICOUT,4121)IBRAN 4121 FORMAT('*****INTERNAL ERROR IN DPORTH--', 1'IMPOSSIBLE CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4122) 4122 FORMAT('THE STRING FIT (OR REGRESSION) NOT FOUND FOR ', 1 'MODEL EXTRACTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4123) 4123 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,4124)(IANS(I),I=1,MIN(100,IWIDTH)) 4124 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 4129 CONTINUE C 4130 CONTINUE IF(ISTOP.EQ.-99)ISTOP=IWIDTH IF(ISTART.LE.ISTOP)GOTO4139 IBRAN=4130 WRITE(ICOUT,4131)IBRAN 4131 FORMAT('INTERNAL ERROR IN DPORTH--AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4133) 4133 FORMAT('ISTART GREATER THAN ISTOP FOR MODEL EXTRACTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4134)ISTART,ISTOP 4134 FORMAT('ISTART, ISTOP = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4135) 4135 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,4136)(IANS(I),I=1,MIN(100,IWIDTH)) 4136 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 4139 CONTINUE C J=0 DO4150I=ISTART,ISTOP J=J+1 ZMODEL(J,1)=IANS(I) 4150 CONTINUE NUMCHZ(1)=ISTOP-ISTART+1 4160 CONTINUE 4190 CONTINUE C C ********************************************** C ** STEP 6.3-- ** C ** FOR ALL VARIATIONS OF THE FIT COMMAND, ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ********************************************** C ISTEPN='6.3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' IKEY='SUBS' IF(IHARG(J1).EQ.'EXCE')IKEY='EXCE' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'ORTH')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ********************************************** C ** STEP 6.4-- ** C ** FOR SOME VARIATIONS OF THE FIT COMMAND, ** C ** EXTRACT THE UNDERLYING FUNCTION ** C ** FROM FUNCTION DEFINITIONS. ** C ********************************************** C C ISTEPN='6.4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NQ.GT.1)GOTO5189 IF(ICASFI.EQ.'ORTF')GOTO5160 GOTO5189 C 5160 CONTINUE IF(IMPFLG.EQ.'ON')THEN ILOCEQ=0 GOTO5176 ENDIF C DO5170I=1,NUMCHZ(1) I2=I IF(ZMODEL(I,1).EQ.'=')GOTO5175 5170 CONTINUE IBRAN=5170 WRITE(ICOUT,5171)IBRAN 5171 FORMAT('*****INTERNAL ERROR IN DPORTH--', 1'IMPOSSIBLE CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5172) 5172 FORMAT('NO EQUAL SIGN FOUND FOR MODEL EXTRACTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5173) 5173 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,5174)(IANS(I),I=1,MIN(100,IWIDTH)) 5174 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 5175 CONTINUE ILOCEQ=I2 C IWD1='= ' IWD12=' ' C 5176 CONTINUE IF(ICASEQ.EQ.'FULL')IWD2=' ' IF(ICASEQ.EQ.'FULL')IWD22=' ' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'SUBS')IWD2='SUBS' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'SUBS')IWD22='ET ' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'EXCE')IWD2='EXCE' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'EXCE')IWD22='PT ' IF(ICASEQ.EQ.'FOR')IWD2='FOR ' IF(ICASEQ.EQ.'FOR')IWD22=' ' C IF(ICASFI.EQ.'ORTF') 1CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3379 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3371) 3371 FORMAT('***** ERROR IN DPORTH--INVALID COMMAND FORM FOR', 1 'FITTING.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3373) 3373 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3374) 3374 FORMAT(' ORTHOGONAL DISTANCE FIT ... = ... ', 1'SUBSET ... ... ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3375) 3375 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,3376)(IANS(I),I=1,MIN(100,IWIDTH)) 3376 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 3379 CONTINUE C CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C J=ILOCEQ DO5180I=1,N3 J=J+1 ZMODEL(J,1)=IFUNC3(I) 5180 CONTINUE NUMCHZ(1)=J C 5189 CONTINUE C C ***************************************************** C ** STEP 7-- ** C ** MAKE A NON-CALCULATING PASS AT THE MODEL ** C ** SO AS TO EXTRACT ALL PARAMETER AND VARIABLE ** C ** NAMES. ** C ***************************************************** C ISTEPN='7' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMF=1 IF(NQ.GT.1)NUMF=NQ DO4499L=1,NUMF IPASS=1 CALL COMPIM(ZMODEL(1,L),NUMCHZ(L),IPASS, 1 PARTMP,IPART1,IPART2,NUMPV, 1 IANGLU,ZTYPEH(1,L),ZW21HO(1,L),ZW22HO(1,L), 1 Z2HOLD(1,L),NWHOLZ(L),AJUNK, 1 IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 8-- ** C ** CHECK TO MAKE SURE THAT THE COMBINED ** C ** NUMBER OF PARAMETERS AND VARIABLES ** C ** IN THE MODEL IS AT LEAST 1. ** C ******************************************** C ISTEPN='8' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMPV.GE.1)GOTO4400 WRITE(ICOUT,4401) 4401 FORMAT('***** ERROR IN DPORTH--COMBINED NUMBER OF PARAMETERS', 1 ' AND VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4403)NUMPV 4403 FORMAT(' DETECTED IN THE MODEL FOR FUNCTION ',I5,' IS 0.', 1 ' NUMPV = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4407)NUMCHZ(L) 4407 FORMAT(' NUMBER OF CHARACTERS IN MODEL = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCHZ(L).GE.1)THEN WRITE(ICOUT,4408)(ZMODEL(J,L),J=1,MIN(100,NUMCHZ(L))) 4408 FORMAT(' MODEL--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 4400 CONTINUE C C ****************************************************** C ** STEP 9-- ** C ** CHECK THAT ALL VARIABLES ** C ** IN THE MODEL ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.) AND ** C ** IHNAM2(.). CHECK THAT ALL PARAMETERS ** C ** IN THE MODEL ARE ALREADY PRESENT IN THE ** C ** AVAILABLE NAME LIST IHNAME(.) AND IHNAM2(.). ** C ** ALL NAMES IN THE MODEL THAT ARE NOT ** C ** IN THE NAME LIST AT ALL WILL BE ADDED ** C ** TO THE LIST, DEFINED AS PARAMETERS, ** C ** AND GIVEN A VALUE OF 1.0. ** C ** THIS ALLOWS US TO MAKE AN INITIAL FIT ** C ** WITHOUT HAVING TO DEFINE STARTING VALUES AT ALL ** C ** (THEY WILL BE AUTOMATICALLY SET TO 1.0). ALSO, ** C ** FORM A NEW VECTOR WHICH HAS ONLY PARAMETER NAMES** C ** AND ANOTHER VECTOR WHICH HAS ONLY VARIABLE NAMES.* C ****************************************************** C ISTEPN='9' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IP=0 IV=0 DO7965J=1,NUMPV IHPARN=IPART1(J) IHPAR2=IPART2(J) DO7966I=1,NUMNAM I2=I IF(IHPARN.EQ.IHNAME(I).AND.IHPAR2.EQ.IHNAM2(I).AND. 1 IUSE(I).EQ.'V')GOTO7980 IF(IHPARN.EQ.IHNAME(I).AND.IHPAR2.EQ.IHNAM2(I).AND. 1 IUSE(I).EQ.'P')GOTO7970 7966 CONTINUE IP=IP+1 ZIPARN(IP,L)=IHPARN ZPARN2(IP,L)=IHPAR2 ZPARAM(IP,L)=1.0 C IF(NUMNAM.LT.MAXNAM)GOTO7769 WRITE(ICOUT,7751) 7751 FORMAT('***** ERROR IN DPORTH--THE TOTAL NUMBER OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7752) 7752 FORMAT(' (VARIABLE + PARAMETER) NAMES MUST BE AT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7753)MAXNAM 7753 FORMAT(' MOST ',I8,'. SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7755) 7755 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES WAS ', 1 'JUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7757) 7757 FORMAT(' EXCEEDED. SUGGESTED ACTION--ENTER STATUS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7758) 7758 FORMAT(' TO DETERMINE THE IMPORTANT (VERSUS ', 1 'UNIMPORTANT) VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7760) 7760 FORMAT(' AND PARAMETERS, AND THEN REUSE SOME OF THE ', 1 'NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7762) 7762 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,7763)(IANS(I),I=1,MIN(100,IWIDTH)) 7763 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 7769 CONTINUE C I2=NUMNAM+1 IHNAME(I2)=IHPARN IHNAM2(I2)=IHPAR2 IUSE(I2)='P' IVALUE(I2)=1 VALUE(I2)=1.0 IN(I2)=1 NUMNAM=I2 IF(IFEEDB.EQ.'OFF')GOTO7859 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7852) 7852 FORMAT(' NOTE--A NAME USED IN AN EXPRESSION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7853)ZIPARN(J,L),ZPARN2(J,L) 7853 FORMAT(' HAS NOT YET BEEN DEFINED. NAME = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7855) 7855 FORMAT(' THIS NAME HAS BEEN ADDED TO THE LIST, SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7857) 7857 FORMAT(' AS A PARAMETER AND GIVEN THE VALUE 1.0 .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7858)(ZMODEL(I,L),I=1,MIN(100,NUMCHZ(L))) 7858 FORMAT(' FUNCTION EXPRESSION--',100A1) CALL DPWRST('XXX','BUG ') 7859 CONTINUE GOTO7965 7970 CONTINUE IP=IP+1 ZIPARN(IP,L)=IHPARN ZPARN2(IP,L)=IHPAR2 ZPARAM(IP,L)=VALUE(I2) GOTO7965 7980 CONTINUE IV=IV+1 ZIDUMV(IV,L)=IHPARN ZDUMV2(IV,L)=IHPAR2 LOCDUM(IV,L)=IVALUE(I2) NIV(IV)=IN(I2) GOTO7965 7965 CONTINUE NUMPAZ(L)=IP NUMVAZ(L)=IV C C ******************************************* C ** STEP 10-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF INDEPENDENT VARIABLES (1 TO 20). ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE INDEPENDENT VARIABLES. ** C ** DOES THE NAME EXIST IN THE TABLE? ** C ** DOES THE NUMBER OF ELEMENTS ** C ** AGREE WITH THE NUMBER OF ELEMENTS ** C ** IN THE RESPONSE VARIABLE? ** C ******************************************* C ISTEPN='10' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMVAZ(L).GE.1.AND.NUMVAZ(L).LE.MAXV2)GOTO520 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4251) 4251 FORMAT('***** ERROR IN DPORTH--FOR AN ORTHOGONAL DISTANCE FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4253) 4253 FORMAT(' THE NUMBER OF INDEPENDENT VARIABLES MUST BE AT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4254)MAXV2 4254 FORMAT(' LEAST 1 AND AT MOST ',I8,' ; SUCH WAS NOT THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4256)L 4256 FORMAT(' THE CASE HERE. FOR FUNCTION ',I5,' THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4257)NUMVAZ(L) 4257 FORMAT(' SPECIFIED NUMBER OF INDEPENDENT VARIABLES WAS ', 1 I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4258) 4258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,4259)(IANS(I),I=1,MIN(100,IWIDTH)) 4259 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4267)NUMCHZ(L) 4267 FORMAT(' NUMBER OF CHARACTERS IN MODEL = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4268)(ZMODEL(JJ,L),JJ=1,MIN(100,NUMCHZ(L))) 4268 FORMAT(' MODEL--',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4264) 4264 FORMAT(' VARIABLES EXTRACTED FROM MODEL--') CALL DPWRST('XXX','BUG ') DO4265JJ=1,NUMVAZ(L) WRITE(ICOUT,4266)JJ,ZIDUMV(JJ,L),ZDUMV2(JJ,L),LOCDUM(JJ,L) 4266 FORMAT('I,IVARN3(I),IVARN4(I),ICOLV3(I) = ',I8,2X,A4,A4,2X,I8) CALL DPWRST('XXX','BUG ') 4265 CONTINUE IERROR='YES' GOTO9000 C 520 CONTINUE IF(IMPFLG.EQ.'ON')THEN NTEMP=NIV(1) DO542JJ=1,NUMVAZ(L) IF(NIV(JJ).NE.NTEMP)GOTO545 542 CONTINUE GOTO590 ELSE NTEMP=NLEFT DO540JJ=1,NUMVAZ(L) IF(NIV(JJ).NE.NTEMP)GOTO560 540 CONTINUE GOTO590 ENDIF C 545 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,546) 546 FORMAT('***** ERROR IN DPORTH--FOR AN IMPLICIT ORTHOGONAL ', 1 'DISTANCE FIT, THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,547) 547 FORMAT(' NUMBER OF ELEMENTS IN EACH INDEPENDENT ', 1 'VARIABLE SHOULD BE THE SAME.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,548)NTEMP 548 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,549) 549 FORMAT(' INDEPENDENT VARIABLES --') CALL DPWRST('XXX','BUG ') DO550JJ=1,NUMVAZ(L) WRITE(ICOUT,552)ZIDUMV(JJ,L),ZDUMV2(JJ,L),NIV(JJ) 552 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,556)(IANS(I),I=1,MIN(100,IWIDTH)) 556 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 560 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT('***** ERROR IN DPORTH--FOR AN ORTHOGONAL DISTANCE ', 1 'FIT, THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,564) 564 FORMAT(' NUMBER OF ELEMENTS IN EACH INDEPENDENT VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,565) 565 FORMAT(' SHOULD BE THE SAME AS THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,566) 566 FORMAT(' IN THE DEPENDENT VARIABLE (RESPONSE); SUCH WAS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT(' NOT THE CASE HERE. DEPENDENT VARIABLE ', 1 '(RESPONSE)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572)IHLEFT,IHLEF2,NLEFT 572 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576) 576 FORMAT(' INDEPENDENT VARIABLES --') CALL DPWRST('XXX','BUG ') DO580JJ=1,NUMVAZ(L) WRITE(ICOUT,578)ZIDUMV(JJ,L),ZDUMV2(JJ,L),NIV(JJ) 578 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') 580 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,588)(IANS(I),I=1,MIN(100,IWIDTH)) 588 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 590 CONTINUE C C UPDATE PARAMETER AND VARIABLE NAME LIST C IF(L.EQ.1)THEN DO4481JJ=1,NUMPAZ(1) IPARN3(JJ)=ZIPARN(JJ,1) IPARN4(JJ)=ZPARN2(JJ,1) PARAM3(JJ)=ZPARAM(JJ,1) 4481 CONTINUE C DO4483JJ=1,NUMVAZ(1) IVARN3(JJ)=ZIDUMV(JJ,1) IVARN4(JJ)=ZDUMV2(JJ,1) ICOLV3(JJ)=LOCDUM(JJ,1) 4483 CONTINUE NUMPAR=NUMPAZ(1) NUMVAR=NUMVAZ(1) ELSE DO4491JJ=1,NUMPAZ(L) DO4493KK=1,NUMPAR IF(ZIPARN(KK,L).EQ.IPARN3(KK).AND. 1 ZPARN2(KK,L).EQ.IPARN4(KK))GOTO4494 4493 CONTINUE NUMPAR=NUMPAR+1 IPARN3(NUMPAR)=ZIPARN(JJ,L) IPARN4(NUMPAR)=ZPARN2(JJ,L) PARAM3(NUMPAR)=ZPARAM(JJ,L) 4494 CONTINUE 4491 CONTINUE C DO4495JJ=1,NUMVAZ(L) DO4496KK=1,NUMVAR IF(ZIDUMV(KK,L).EQ.IVARN3(KK).AND. 1 ZDUMV2(KK,L).EQ.IVARN4(KK))GOTO4497 4496 CONTINUE NUMVAR=NUMVAR+1 IVARN3(NUMVAR)=ZIDUMV(JJ,L) IVARN4(NUMVAR)=ZDUMV2(JJ,L) ICOLV3(NUMVAR)=LOCDUM(JJ,L) 4497 CONTINUE 4495 CONTINUE ENDIF C 4499 CONTINUE C DO4498JJ=1,NUMVAR IPARN3(NUMPAR+JJ)=IVARN3(JJ) IPARN4(NUMPAR+JJ)=IVARN4(JJ) 4498 CONTINUE C C C ****************************************************** C ** STEP 11-- ** C ** CHECK FOR ADEQUATE AMOUNT OF SCRATCH SPACE ** C ****************************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C M=NUMVAR NP=NUMPAR N=NLEFT IF(IMPFLG.EQ.'ON')THEN N=NIV(1) ENDIF C IREQ=18 + 11*NP + NP**2 + M + M**2 + 4*N*NQ + 6*N*M + 1 2*N*NQ*M + 2*N*NQ*NP + NQ**2 + 5*NQ + NQ*(NP+M) + (N*1)*NQ LWORK=46*MAXOBV/2 IF(IREQ.GT.LWORK)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,591) 591 FORMAT('***** ERROR FROM DPORTH--NOT ENOUGH SCRATCH STORAGE', 1 ' AVAILABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,593)IREQ,LWORK 593 FORMAT(' AVAILABLE STORAGE = ',I8,' AND REQUIRED ', 1 'STORAGE = ',I8,'.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,595) 595 FORMAT(' REMEDY: REDUCE EITHER THE NUMBER OF VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,597) 597 FORMAT(' OR THE NUMBER OF OBSERVATIONS IN THE MODEL.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C ****************************************************** C ** STEP 11B-- ** C ** CHECK DELTA WEIGHT VARIABLES FOR APPROPRIATE ** C ** SIZES. (IF NOT EQUAL 'OFF'). CASES: ** C ** 1) IF MORE THAN ONE VARIABLE, THEN SIZE OF EACH ** C ** VARIABLE MUST EQUAL SIZE OF RESPONSE VARIABLE** C ** 2) IF EXACTLY ONE VARIABLE, THEN CHECK ** C ** VARIABLE MUST EQUAL SIZE OF RESPONSE VARIABLE** C ** OR EQUAL NUMBER OF INDEPENDENT VARIABLES ** C ****************************************************** C ISTEPN='11B' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IDLFLG.EQ.'OFF' .OR. IDLFLG.EQ.'DEFA')GOTO729 C IF(NUMDEL.EQ.1)THEN IF(NDELTA(1).EQ.N .OR. NDELTA(1).EQ.M)GOTO729 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,711) 711 FORMAT('***** ERROR FROM DPORTH--IF EXACTLY ONE DELTA ', 1 'VARIABLE SPECIFIED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,713) 713 FORMAT(' THE NUMBER OF ELEMENTS MUST EQUAL EITHER THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,715)N 715 FORMAT(' NUMBER OF ELEMENTS IN THE RESPONSE VARIABLE (', 1 I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,717)M 717 FORMAT(' OR THE NUMBER OF RESPONSE VARIABLES (',I8,').') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,719)IODRD1(1),IODRD2(1),NDELTA(1) 719 FORMAT(' DELTA VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS.') IERROR='YES' GOTO9000 ELSEIF(NUMDEL.GT.1)THEN DO720JJ=1,NUMDEL NTEMP=NLEFT IF(IMPFLG.EQ.'ON')NTEMP=NIV(1) IF(NDELTA(JJ).NE.NTEMP)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,721)IODRD1(JJ),IODRD2(JJ),NDELTA(JJ) 721 FORMAT('***** ERROR IN DPORTH--DELTA VARIABLE ',A4,A4, 1 ' HAS ',I8,' ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,722) 722 FORMAT(' HOWEVER, IT SHOULD HAVE THE SAME NUMBER OF ', 1 'ELEMENTS AS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,723)N 723 FORMAT(' INDEPENDENT VARIABLE(S).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,725)IVARN3(1),IVARN4(1),NTEMP 725 FORMAT(' FIRST INDEPENDENT VARIABLE ', 1 A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,727) 727 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,728)(IANS(I),I=1,MIN(100,IWIDTH)) 728 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF 720 CONTINUE ELSE GOTO729 ENDIF C 729 CONTINUE C C ****************************************************** C ** STEP 11C-- ** C ** CHECK DELTA FIXED VARIABLES FOR APPROPRIATE ** C ** SIZES. (IF NOT EQUAL 'OFF'). CASES: ** C ** 1) IF MORE THAN ONE VARIABLE, THEN SIZE OF EACH ** C ** VARIABLE MUST EQUAL SIZE OF RESPONSE VARIABLE** C ** 2) IF EXACTLY ONE VARIABLE, THEN CHECK ** C ** VARIABLE MUST EQUAL SIZE OF RESPONSE VARIABLE** C ** OR EQUAL NUMBER OF INDEPENDENT VARIABLES ** C ****************************************************** C ISTEPN='11C' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IODRE1(1).EQ.'OFF' .OR. NUMERR.EQ.0)GOTO749 C IF(NUMERR.EQ.1)THEN IF(NERROR(1).EQ.N .OR. NERROR(1).EQ.M)GOTO749 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,731) 731 FORMAT('***** ERROR FROM DPORTH--IF EXACTLY ONE ERROR ', 1 'VARIABLE SPECIFIED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,733) 733 FORMAT(' THE NUMBER OF ELEMENTS MUST EQUAL EITHER THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,735)N 735 FORMAT(' NUMBER OF ELEMENTS IN THE RESPONSE VARIABLE (', 1 I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,737)M 737 FORMAT(' OR THE NUMBER OF RESPONSE VARIABLES (',I8,').') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,739)IODRE1(1),IODRE2(1),NERROR(1) 739 FORMAT(' ERROR VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS.') IERROR='YES' GOTO9000 ELSEIF(NUMERR.GT.1)THEN DO740JJ=1,NUMERR NTEMP=NLEFT IF(IMPFLG.EQ.'ON')NTEMP=NIV(1) IF(NERROR(JJ).NE.NTEMP)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,741)IODRE1(JJ),IODRE2(JJ),NDELTA(JJ) 741 FORMAT('***** ERROR IN DPORTH--ERROR VARIABLE ',A4,A4, 1 ' HAS ',I8,' ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,742) 742 FORMAT(' HOWEVER, IT SHOULD HAVE THE SAME NUMBER OF ', 1 'ELEMENTS AS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,743)N 743 FORMAT(' INDEPENDENT VARIABLE(S).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,745)IVARN3(1),IVARN4(1),NTEMP 745 FORMAT(' FIRST INDEPENDENT VARIABLE ', 1 A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,747) 747 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,748)(IANS(I),I=1,MIN(100,IWIDTH)) 748 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF 740 CONTINUE ELSE GOTO749 ENDIF C 749 CONTINUE C C ****************************************************** C ** STEP 11D-- ** C ** CHECK DELTA STARTING VALUE VARIABLES FOR ** C ** APPROPRIATE SIZES. (IF NOT EQUAL 'OFF'). ** C ****************************************************** C ISTEPN='11D' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IODRD3(3).EQ.'OFF')GOTO779 IF(IODRD3(3).EQ.'ON')GOTO779 IF(NUMDE2.LT.1)GOTO779 C NTEMP=NLEFT IF(IMPFLG.EQ.'ON')NTEMP=NIV(1) DO770J=1,NUMDE2 IF(NDELT2(J).NE.NTEMP)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,771) 771 FORMAT('***** ERROR IN DPORTH--DELTA STARTING VALUE ', 1 'VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,772) 772 FORMAT(' HOWEVER, IT SHOULD HAVE THE SAME NUMBER OF ', 1 'ELEMENTS AS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,773)N 773 FORMAT(' INDEPENDENT VARIABLE(S).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,775)IVARN3(1),IVARN4(1),NTEMP 775 FORMAT(' FIRST INDEPENDENT VARIABLE ', 1 A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,777) 777 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,778)(IANS(I),I=1,MIN(100,IWIDTH)) 778 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF 770 CONTINUE C 779 CONTINUE C C ***************************************************** C ** STEP 12-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; THEN ** C ** COPY OVER THE RESPONSE VECTOR TO BE USED IN ** C ** THE MODEL INTO THE VECTOR Y; AND ** C ** COPY OVER THE WEIGHTS INTO THE VECTOR W; COPY ** C ** OVER THE VECTORS THAT WERE USED IN THE MODEL ** C ** INTO XMAT, COPY OVER THE DELTAS INTO RHO, AND ** C ** THE ERROR VARIABLE INTO IFIX. ** C ***************************************************** C ISTEPN='12' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')WRITE(ICOUT,601)N,NUMVAR 601 FORMAT('N,NUMVAR = ',2I8) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH')CALL DPWRST('XXX','BUG ') C NTEMP=NLEFT IF(IMPFLG.EQ.'ON')NTEMP=NIV(1) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NTEMP ISUB(I)=1 615 CONTINUE NQZ=NTEMP GOTO650 C 620 CONTINUE NIOLD=NTEMP CALL DPSUB2(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQZ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NTEMP CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQZ=NFOR GOTO650 C 650 CONTINUE IF(IMPFLG.NE.'ON')THEN K=ICOLL J=0 LDX=0 DO4500I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4500 LDX=LDX+1 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)YTEMP(J)=V(IJ) IF(K.EQ.MAXCP1)YTEMP(J)=PRED(I) IF(K.EQ.MAXCP2)YTEMP(J)=RES(I) IF(K.EQ.MAXCP3)YTEMP(J)=YPLOT(I) IF(K.EQ.MAXCP4)YTEMP(J)=XPLOT(I) IF(K.EQ.MAXCP5)YTEMP(J)=X2PLOT(I) IF(K.EQ.MAXCP6)YTEMP(J)=TAGPLO(I) 4500 CONTINUE IF(NQ.GT.1)THEN IF(NQ*LDX.GT.MAXOB2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4511)NQ*LDX 4511 FORMAT('***** ERROR IN DPORTH--TOTAL NUMBER OF RESPONSE ', 1 'VALUES (= ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4513)MAXOB2 4513 FORMAT(' EXCEEDS THE MAXIMUM ALLOWED OF (',I8,').') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF DO4505JJ=2,NQ J=(JJ-1)*LDX K=ICOLRV(JJ) DO4508I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4508 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)YTEMP(J)=V(IJ) IF(K.EQ.MAXCP1)YTEMP(J)=PRED(I) IF(K.EQ.MAXCP2)YTEMP(J)=RES(I) IF(K.EQ.MAXCP3)YTEMP(J)=YPLOT(I) IF(K.EQ.MAXCP4)YTEMP(J)=XPLOT(I) IF(K.EQ.MAXCP5)YTEMP(J)=X2PLOT(I) IF(K.EQ.MAXCP6)YTEMP(J)=TAGPLO(I) 4508 CONTINUE 4505 CONTINUE ENDIF ELSE LDX=0 DO4501I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4501 LDX=LDX+1 J=J+1 YTEMP(J)=0.0D0 4501 CONTINUE ENDIF C IF(IMPFLG.NE.'ON')THEN W(1)=-1.0D0 K=ICOLWR(1) J=0 DO4580I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4580 J=J+1 IF(K.LE.0)THEN W(J)=-1.0D0 ELSE IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)W(J)=V(IJ) IF(K.EQ.MAXCP1)W(J)=PRED(I) IF(K.EQ.MAXCP2)W(J)=RES(I) IF(K.EQ.MAXCP3)W(J)=YPLOT(I) IF(K.EQ.MAXCP4)W(J)=XPLOT(I) IF(K.EQ.MAXCP5)W(J)=X2PLOT(I) IF(K.EQ.MAXCP6)W(J)=TAGPLO(I) ENDIF 4580 CONTINUE IF(NQ.GT.1)THEN DO4585JJ=2,NQ J=(JJ-1)*LDX K=ICOLWR(JJ) DO4588I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4588 J=J+1 IF(K.LE.0)THEN W(J)=1.0 ELSE IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)W(J)=V(IJ) IF(K.EQ.MAXCP1)W(J)=PRED(I) IF(K.EQ.MAXCP2)W(J)=RES(I) IF(K.EQ.MAXCP3)W(J)=YPLOT(I) IF(K.EQ.MAXCP4)W(J)=XPLOT(I) IF(K.EQ.MAXCP5)W(J)=X2PLOT(I) IF(K.EQ.MAXCP6)W(J)=TAGPLO(I) ENDIF 4588 CONTINUE 4585 CONTINUE ENDIF ELSE W(1)=-1.0D0 ENDIF C LDIFX=1 IF(IODRE1(1).EQ.'OFF')THEN DO381J=1,M IFIX(J)=0 381 CONTINUE ELSEIF(IODRE1(1).EQ.'ON')THEN DO382J=1,M IFIX(J)=1 382 CONTINUE ELSEIF(NUMERR.GE.1 .AND. NERROR(1).EQ.N)THEN LDIFX=LDX DO4591L=1,NUMERR K=ICOLE(L) J=(L-1)*LDX DO4593I=1,NERROR(L) J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)IFIX(J)=INT(ABS(V(IJ))+0.5) IF(K.EQ.MAXCP1)IFIX(J)=INT(ABS(PRED(I))+0.5) IF(K.EQ.MAXCP2)IFIX(J)=INT(ABS(RES(I))+0.5) IF(K.EQ.MAXCP3)IFIX(J)=INT(ABS(YPLOT(I))+0.5) IF(K.EQ.MAXCP4)IFIX(J)=INT(ABS(XPLOT(I))+0.5) IF(K.EQ.MAXCP5)IFIX(J)=INT(ABS(X2PLOT(I))+0.5) IF(K.EQ.MAXCP6)IFIX(J)=INT(ABS(TAGPLO(I))+0.5) 4593 CONTINUE 4591 CONTINUE ELSEIF(NUMERR.GE.1 .AND. NERROR(1).EQ.M)THEN LDIFX=1 K=ICOLE(1) J=0 DO4597I=1,NERROR(1) J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)IFIX(J)=INT(ABS(V(IJ))+0.5) IF(K.EQ.MAXCP1)IFIX(J)=INT(ABS(PRED(I))+0.5) IF(K.EQ.MAXCP2)IFIX(J)=INT(ABS(RES(I))+0.5) IF(K.EQ.MAXCP3)IFIX(J)=INT(ABS(YPLOT(I))+0.5) IF(K.EQ.MAXCP4)IFIX(J)=INT(ABS(XPLOT(I))+0.5) IF(K.EQ.MAXCP5)IFIX(J)=INT(ABS(X2PLOT(I))+0.5) IF(K.EQ.MAXCP6)IFIX(J)=INT(ABS(TAGPLO(I))+0.5) 4597 CONTINUE ELSE IFIX(1)=-1 LDIFX=1 ENDIF C IF(NUMVAR.GE.1)THEN DO385L=1,NUMVAR K=ICOLV3(L) J=(L-1)*LDX DO386I=1,NTEMP IF(ISUB(I).EQ.0)GOTO386 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)XMAT(J)=V(IJ) IF(K.EQ.MAXCP1)XMAT(J)=PRED(I) IF(K.EQ.MAXCP2)XMAT(J)=RES(I) IF(K.EQ.MAXCP3)XMAT(J)=YPLOT(I) IF(K.EQ.MAXCP4)XMAT(J)=XPLOT(I) IF(K.EQ.MAXCP5)XMAT(J)=X2PLOT(I) IF(K.EQ.MAXCP6)XMAT(J)=TAGPLO(I) 386 CONTINUE 385 CONTINUE ENDIF IF(IMPFLG.EQ.'ON')N=LDX C IF(NUMDEL.GE.1.AND.NDELTA(1).EQ.N)THEN LDRHO=LDX DO395L=1,NUMDEL K=ICOLD(L) J=(L-1)*LDX DO396I=1,NTEMP IF(ISUB(I).EQ.0)GOTO396 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)RHO(J)=V(IJ) IF(K.EQ.MAXCP1)RHO(J)=PRED(I) IF(K.EQ.MAXCP2)RHO(J)=RES(I) IF(K.EQ.MAXCP3)RHO(J)=YPLOT(I) IF(K.EQ.MAXCP4)RHO(J)=XPLOT(I) IF(K.EQ.MAXCP5)RHO(J)=X2PLOT(I) IF(K.EQ.MAXCP6)RHO(J)=TAGPLO(I) 396 CONTINUE 395 CONTINUE ELSEIF(NUMDEL.EQ.1.AND.NDELTA(1).EQ.M)THEN LDRHO=1 J=0 K=ICOLD(1) DO398I=1,M J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)RHO(J)=V(IJ) IF(K.EQ.MAXCP1)RHO(J)=PRED(I) IF(K.EQ.MAXCP2)RHO(J)=RES(I) IF(K.EQ.MAXCP3)RHO(J)=YPLOT(I) IF(K.EQ.MAXCP4)RHO(J)=XPLOT(I) IF(K.EQ.MAXCP5)RHO(J)=X2PLOT(I) IF(K.EQ.MAXCP6)RHO(J)=TAGPLO(I) 398 CONTINUE DO399I=M+1,N*M RHO(I)=0.0D0 399 CONTINUE ELSE LDRHO=1 RHO(1)=-1.0 ENDIF C IF(NUMDE2.GE.1.AND.(IODRD3(1).NE.'OFF'.AND.IODRD3(1).NE.'ON'))THEN DO405L=1,NUMDE2 K=ICOLD2(L) J=(L-1)*LDX DO406I=1,NTEMP IF(ISUB(I).EQ.0)GOTO406 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)WORK(J)=V(IJ) IF(K.EQ.MAXCP1)WORK(J)=PRED(I) IF(K.EQ.MAXCP2)WORK(J)=RES(I) IF(K.EQ.MAXCP3)WORK(J)=YPLOT(I) IF(K.EQ.MAXCP4)WORK(J)=XPLOT(I) IF(K.EQ.MAXCP5)WORK(J)=X2PLOT(I) IF(K.EQ.MAXCP6)WORK(J)=TAGPLO(I) 406 CONTINUE 405 CONTINUE ELSE DO408I=1,N*M WORK(I)=0.0D0 408 CONTINUE ENDIF C C ****************************************************** C ** STEP 13-- ** C ** PREPARE FOR ENTRANCE INTO DPORTH2 ** C ** SET THE ICON3 VECTOR ** C ** (WHICH INDICATES WHICH PARAMETERS ARE TO BE HELD** C ** CONSTANT) EQUAL TO 0 THROUGHOUT. ** C ** DEFINE CONSTRAINTS AND LIMITS. ** C ****************************************************** C ISTEPN='13' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO4195I=1,NUMPAR ICON3(I)=0 4195 CONTINUE C IF(NUMCON.EQ.0)GOTO4890 DO4700I=1,NUMPAR DO4800J=1,NUMCON J2=J IF(IPARN3(I).EQ.IPARNC(J).AND.IPARN4(I).EQ.IPANC2(J))GOTO4810 4800 CONTINUE IPARO3(I)='NONE' GOTO4700 4810 CONTINUE IPARO3(I)=IPAROC(J2) PARLI3(I)=PARLIM(J2) 4700 CONTINUE 4890 CONTINUE C C ****************************************************** C ** STEP 14-- ** C ** CARRY OUT THE ACTUAL FIT ** C ** VIA CALLING ** C ** DPORTH2 (FOR GENERAL MODELS), OR ** C ****************************************************** C ISTEPN='14' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IBUGAZ=IBUGA3 C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'ORTH')GOTO6099 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6081) 6081 FORMAT('***** FROM DPORTH, AS ABOUT TO CALL DPORT2--') CALL DPWRST('XXX','BUG ') DO6083I=1,NS WRITE(ICOUT,6084)I,Y(I),XMAT(I),W(I),RHO(I),IFIX(I) 6084 FORMAT('I,Y(I),XMAT(I),W(I) = ',I6,2X,4F10.5,2X,I6) CALL DPWRST('XXX','BUG ') 6083 CONTINUE DO6185L=1,MAX(NQ,1) WRITE(ICOUT,6082)NUMCHZ(L),NLEFT,MAXN,NS,NUMPAZ(L),NUMVAZ(L) 6082 FORMAT('NUMCHA,NLEFT,MAXN,NS,NUMPAR,NUMVAR = ',7I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6187)L,NUMCHZ(L) 6187 FORMAT('L,NUMCHZ(L) = ',I5,I5) WRITE(ICOUT,6085)(ZMODEL(I,L),I=1,MIN(120,NUMCHZ(L))) 6085 FORMAT('MODEL(.)--',120A1) CALL DPWRST('XXX','BUG ') 6185 CONTINUE DO6286L=1,MAX(NQ,1) DO6086J=1,NUMPAZ(L) WRITE(ICOUT,6087)J,ZIPARN(J,L),ZPARN2(J,L),PARAM3(J),ICON3(J) 6087 FORMAT('I,ZIPARN(I),ZPARN2(I),PARAM3(I),ICON3(I) = ', 1I8,2X,A4,A4,E15.7,A4) CALL DPWRST('XXX','BUG ') 6086 CONTINUE DO6088J=1,NUMVAZ(L) WRITE(ICOUT,6089)J,ZIDUMV(J,L),ZDUMV2(J,L),LOCDUM(J,L) 6089 FORMAT('I,ZIDUMV(I,L),ZDUMV2(I,L),LOCDUM(I,L) = ', 1 I8,2X,A4,A4,2X,I8) CALL DPWRST('XXX','BUG ') 6088 CONTINUE 6286 CONTINUE WRITE(ICOUT,6091)IBUGA3,IBUGCO,IBUGEV,NUMIND 6091 FORMAT('IBUGA3,IBUGCO,IBUGEV,NUMIND = ',A4,2X,A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 6099 CONTINUE C 6520 CONTINUE C LIWORK=MAXOBV C CALL DPORT2(YTEMP,N,XMAT,LDX,RHO,LDRHO,IFIX,LDIFX,NP,M,NQ, 1WORK,LWORK,IWORK,LIWORK,W, 1PARAM3,IPARN3,IPARN4,MAXITS, 1IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF, 1PODRTF,PODRST,PODRPT,IODRPO,IODRE1, 1IMPFLG, 1IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO6590 C 6590 CONTINUE C C *************************************** C ** STEP 15-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C 7000 CONTINUE C ISTEPN='15' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICOLPR=MAXCP1 ICOLRE=MAXCP2 IREPU='OFF' IRESU='ON' REPSD=0.0 REPDF=0.0 C CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NLEFT, 1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,ILOCN,IBUGA3,IERROR) C 7900 CONTINUE C C ************************************************* C ** STEP 17-- ** C ** COPY THE FINAL ESTIMATES FROM THE FIT ** C ** BACK INTO THE PARAMETERS. ** C ** THESE FINAL ESTIMATES WILL THUS OVERWRITE ** C ** THE STARTING VALUES THAT WERE ** C ** ORIGINALLY ASSIGNED TO THE PARAMETERS. ** C ************************************************* C 6000 CONTINUE C ISTEPN='17' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ORTH') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMPAR.LE.0)GOTO6190 DO6100J=1,NUMPAR IH=IPARN3(J) IH2=IPARN4(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 VALUE(ILOCP)=PARAM3(J) 6100 CONTINUE 6190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'ORTH')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPORTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NS,ICASFI 9015 FORMAT('NS,ICASFI = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMNAM 9016 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO9017I=1,NUMNAM WRITE(ICOUT,9018)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 9018 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 9017 CONTINUE 9042 CONTINUE 9049 CONTINUE WRITE(ICOUT,9051)MAXN2,NLEFT,NS,V(1),PRED(1),RES(1) 9051 FORMAT('MAXN2,NLEFT,NS,V(1),PRED(1),RES(1) = ',3I8,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)ICASEQ 9052 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9053)ICOLW,NWEIGH,IWEIGH 9053 FORMAT('ICOLW,NWEIGH,IWEIGH = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9061)IWIDTH 9061 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9062)(IANS(I),I=1,IWIDTH) 9062 FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,9069)IFOUND,IERROR 9069 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPORT2(Y,N,XMAT,LDX,RHO,LDRHO,IFIX,LDIFX,NP,M,NQ, 1WORK,LWORK,IWORK,LIWORK,W, 1PARAM3,IPARN3,IPARN4,MAXITS, 1IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF, 1PODRTF,PODRST,PODRPT,IODRPO,IODRE1, 1IMPFLG, 1IBUGA3,ISUBRO,IERROR) C C USE ODRPACK TO COMPUTE ORTHOGONAL DISTANCE REGRESSION (ALSO C CALLED ERRORS IN VARIABLES REGRESSION). C C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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--2001/4 C ORIGINAL VERSION--APRIL 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IODRE1(*) CHARACTER*4 IODRPO CHARACTER*4 IREP CHARACTER*4 IMPFLG CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*80 IFILE1 CHARACTER*12 ISTAT1 CHARACTER*12 IFORM1 CHARACTER*12 IACCE1 CHARACTER*12 IPROT1 CHARACTER*12 ICURS1 CHARACTER*4 IERRF1 CHARACTER*4 IENDF1 CHARACTER*4 IREWI1 C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IERRF2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 C CHARACTER*80 IFILE3 CHARACTER*12 ISTAT3 CHARACTER*12 IFORM3 CHARACTER*12 IACCE3 CHARACTER*12 IPROT3 CHARACTER*12 ICURS3 CHARACTER*4 IERRF3 CHARACTER*4 IENDF3 CHARACTER*4 IREWI3 C CHARACTER*80 IFILE4 CHARACTER*12 ISTAT4 CHARACTER*12 IFORM4 CHARACTER*12 IACCE4 CHARACTER*12 IPROT4 CHARACTER*12 ICURS4 CHARACTER*4 IERRF4 CHARACTER*4 IENDF4 CHARACTER*4 IREWI4 C CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C INTEGER N, NQ, M, NP C INTEGER IFIXB(1) INTEGER IFIX(LDIFX,M) INTEGER IWORK(*) C DOUBLE PRECISION SCLD(1,1) DOUBLE PRECISION SCLB(1) DOUBLE PRECISION STPB(1) DOUBLE PRECISION STPD(1,1) DOUBLE PRECISION BETA(100) DOUBLE PRECISION TAUFAC DOUBLE PRECISION SSTOL DOUBLE PRECISION PARTOL C DOUBLE PRECISION XMAT(LDX,M) DOUBLE PRECISION RHO(LDRHO,1,M) DOUBLE PRECISION WORK(*) DOUBLE PRECISION Y(N,NQ) DOUBLE PRECISION W(N,1,NQ) REAL PRED2(*) REAL RES2(*) C INTEGER DELTAI, EPSI, XPLUSI, FNI, SDI, VCVI INTEGER RVARI, WSSI, WSSDEI, WSSEPI, RCONDI, ETAI INTEGER OLMAVI, TAUI, ALPHAI, ACTRSI, PNORMI, RNORSI, PRERSI INTEGER PARTLI, SSTOLI, TAUFCI, EPSMAI INTEGER BETA0I, BETACI, BETASI, BETANI, SI, SSI, SSFI, QRAUXI, UI INTEGER FSI, FJACBI, WE1I, DIFFI INTEGER DELTSI, DELTNI, TI, TTI, OMEGAI, FJACDI INTEGER WRK1I, WRK2I, WRK3I, WRK4I, WRK5I, WRK6I, WRK7I INTEGER LWKMN C INTEGER 1 MSGBI, MSGDI, IFIX2I, ISTOPI, 1 NNZWI, NPPI, IDFI, 1 JOBI, IPRINI, LUNERI, LUNRPI, 1 NROWI, NTOLI, NETAI, 1 MAXITI, NITERI, NFEVI, NJEVI, INT2I, IRANKI, LDTTI, 1 LIWKMN C INTEGER LDRHO, LD2WD, LDWE, LD2WE C LOGICAL ISODR C C--------------------------------------------------------------------- C INCLUDE 'DPCOF2.INC' C CHARACTER*4 IPARN3 CHARACTER*4 IPARN4 DIMENSION IPARN3(*) DIMENSION IPARN4(*) DIMENSION PARAM3(*) C EXTERNAL FUN 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='DPOR' ISUBN2='T2 ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'ORT2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPORT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,NP,M,NQ 52 FORMAT('N,NP,M,NQ = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)LDX,LDIFX,LDRHO 53 FORMAT('LDX,LDIFX,LDRHO = ',3I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I,1),XMAT(I,1),RHO(I,1,1),W(I,1,1) 56 FORMAT('I,Y(I,1),XMAT(I,1),RHO(I,1,1),W(I,1) = ', 1 I5,4G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO63J=1,MAX(LDIFX,M) WRITE(ICOUT,64)J,(IFIX(J,L),L=1,M) 64 FORMAT('I,IFIX(I,L),L=1,M) = ',20I3) CALL DPWRST('XXX','BUG ') 63 CONTINUE DO76J=1,N*M WRITE(ICOUT,77)J,WORK(J) 77 FORMAT('J,WORK(J) =',I8,G15.7) CALL DPWRST('XXX','BUG ') 76 CONTINUE 90 CONTINUE C C ************************************************** C ** STEP 0.5-- ** C ** OPEN THE STORAGE FILES ** C ************************************************** C ISTEPN='0.5' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='FIT2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='FIT2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IOUNI3=IST3NU IFILE3=IST3NA ISTAT3=IST3ST IFORM3=IST3FO IACCE3=IST3AC IPROT3=IST3PR ICURS3=IST3CS ISUBN0='ORT2' IERRF3='NO' C IREWI3='ON' CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='ORT2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 C C ***************************************************** C ** STEP 2-- ** C ** DEFINE NEED VALUES AND THEN CALL ODRPACK ** C ** DRIVER ROUTINE (DODRC). ** C ** INITIALIZE VALUES THAT USE DEFAULT VALUES. ** C ***************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ORT2') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C DEFINE STARTING VALUES FOR FUNCTION PARAMETERS DO110I=1,MIN(NP,100) BETA(I)=DBLE(PARAM3(I)) 110 CONTINUE LDNP=NP C C DEPENDENT AND EXPLANATORY VARIABLES LDY=LDX LDN=LDX C C WEIGHTS LDWE=LDY IF(IMPFLG.EQ.'ON')THEN LDWE=1 W(1,1,1)=-1.0D0 ENDIF LD2WE=1 LD2WD=1 C C PARAMETER AND VARIABLE FIXING IFIXB(1)=-1 C C COMPUTATION AND INITIALIZATION CONTROL ISODR=.TRUE. IF(IMPFLG.EQ.'ON')THEN IDIG1=1 ELSE IDIG1=0 IF(IODRE1(1).EQ.'OFF')THEN IDIG1=2 ISODR=.FALSE. ENDIF ENDIF IDIG2=1 IF(IMPFLG.EQ.'ON')IDIG2=0 IDIG3=0 IDIG4=0 IF(WORK(1).NE.0.0D0)IDIG4=1 IDIG5=0 JOB=IDIG1 + 10*IDIG2 + 100*IDIG3 + 1000*IDIG4 + 10000*IDIG5 NDIGIT=-1 TAUFAC=PODRTF C C STOPPING CRITIERION SSTOL=PODRST PARTOL=PODRPT MAXITF=MAXITS C C PRINT CONTROL LUNERR=IPR LUNRPT=IPR IF(IODRPO.EQ.'FULL')THEN IPRNT=2212 ELSEIF(IODRPO.EQ.'INTE')THEN IPRNT=1111 ELSEIF(IODRPO.EQ.'SHOR')THEN IPRNT=1001 ELSE IPRNT=1111 ENDIF C C DERIVATIVE STEP SIZES STPD(1,1)=-1.0D0 STPB(1)=-1.0D0 LDSTPD=1 C C SCALING SCLD(1,1)=-1.0D0 LDSCLD=1 SCLB(1)=-1.0D0 C C STOPPING CONDITION C CCCCC FOLLOWING LINES WERE TEMPORARY DEBUGGING ccccc print *,'n,m,np,nq=',n,m,np,nq ccccc print *,'beta = ',(beta(i),i=1,np) ccccc print *,'y = ',(Y(i,1),i=1,n) ccccc print *,'ldy,ldx,ldwe,ld2we=',ldy,ldx,ldwe,ld2we ccccc print *,'xmat=',((xmat(i,j),i=1,n),j=1,m) ccccc print *,'w=',(w(i,1,1),i=1,n) ccccc print *,'rho=',(rho(i,1,1),i=1,n) ccccc print *,'ifixb(1)=',ifixb(1) ccccc print *,'ifix=',((ifix(i,j),i=1,n),j=1,m) ccccc print *,'ldifx,ldrho,ld2wd=',ldifx,ldrho,ld2wd ccccc print *,'job,ndigit,taufac=',job,ndigit,taufac ccccc print *,'sstol,partol,maxitf=',sstol,partol,maxitf ccccc print *,'iprnt,lunerr,lunrpt=',iprnt,lunerr,lunrpt ccccc print *,'stpb,stpd,ldstpd=',stpb(1),stpd(1,1),ldstpd ccccc print *,'sclb,scld,ldscd=',sclb(1),scld(1,1),ldscld ccccc print *,'work=',(work(i),i=1,n*m) ccccc print *,'lwork.liwork=',lwork,liwork ccccc print *,'info=',info C CALL DODRC( 1 FUN, 1 N, M, NP, NQ, 1 BETA, 1 Y, LDY, XMAT, LDX, 1 W, LDWE, LD2WE, RHO, LDRHO, LD2WD, 1 IFIXB, IFIX, LDIFX, 1 JOB, NDIGIT, TAUFAC, 1 SSTOL, PARTOL, MAXITF, 1 IPRNT,LUNERR,LUNRPT, 1 STPB, STPD, LDSTPD, 1 SCLB, SCLD,LDSCLD, 1 WORK, LWORK, IWORK, LIWORK, 1 INFO) C DO120I=1,MIN(NP,100) PARAM3(I)=REAL(BETA(I)) 120 CONTINUE C C CHECK FOR ERROR MESSAGES C IF(INFO.GE.0)THEN IDIG5 = MOD(INFO,100000)/10000 IDIG4 = MOD(INFO,10000)/1000 IDIG3 = MOD(INFO,1000)/100 IDIG2 = MOD(INFO,100)/10 IDIG1 = MOD(INFO,10) ENDIF C IF(INFO.LT.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,208) 208 FORMAT('***** ERROR FROM DPORT2--COMPUTATIONS STOPPED IN ', 1 'FUNCTION EVALUATION ROUTINE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(INFO.GE.1 .AND. INFO.LE.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,210) 210 FORMAT('***** ODRPACK CONVERGED SUCCESSFULLY.') CALL DPWRST('XXX','BUG ') IF(INFO.EQ.1)WRITE(ICOUT,211) IF(INFO.EQ.2)WRITE(ICOUT,212) IF(INFO.EQ.3)WRITE(ICOUT,213) 211 FORMAT(' SUM-OF-SQUARES CONVERGENCE.') 212 FORMAT(' PARAMETER CONVERGENCE.') 213 FORMAT(' BOTH SUM-OF-SQUARES CONVERGENCE AND PARAMETER ', 1 'CONVERGENCE.') CALL DPWRST('XXX','BUG ') ELSEIF(INFO.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,410)MAXITF 410 FORMAT('***** WARNING: ODRPACK REACHED MAXIMUM NUMBER OF ', 1 'ITERATIONS,',I8,' WITHOUT CONVERGING.') CALL DPWRST('XXX','BUG ') ELSEIF(INFO.GT.4 .AND. IDIG5.EQ.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,510) 510 FORMAT('***** WARNING: ODRPACK RESULTS QUESTIONABLE.') CALL DPWRST('XXX','BUG ') IF(IDIG4.GE.1)THEN WRITE(ICOUT,502) 502 FORMAT(' DERIVATIVES POSSIBLY NOT CORRECT.') CALL DPWRST('XXX','BUG ') ELSEIF(IDIG3.GE.1 )THEN WRITE(ICOUT,511) 511 FORMAT(' LAST FUNCTION EVALUATION RETURNED AN ERROR.') CALL DPWRST('XXX','BUG ') ELSEIF(IDIG2.GE.2)THEN WRITE(ICOUT,513) 513 FORMAT(' PROBLEM IS NOT FULL RANK AT SOLUTION.') CALL DPWRST('XXX','BUG ') ENDIF ELSEIF(INFO.GT.4 .AND. IDIG5.GE.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,610) 610 FORMAT('***** ERROR: ODRPACK DETECTED FATAL ERRORS IN ', 1 'USER INPUT.') CALL DPWRST('XXX','BUG ') IF(IDIG5.EQ.1 .AND. IDIG4.GE.1)THEN WRITE(ICOUT,620) 620 FORMAT(' NUMBER OF OBSERVATIONS LESS THAN 1.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.1 .AND. IDIG3.GE.1)THEN WRITE(ICOUT,630) 630 FORMAT(' NUMBER OF INDEPENDENT VARIABLES LESS THAN ', 1 '1.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.1 .AND. IDIG2.GE.1)THEN WRITE(ICOUT,640) 640 FORMAT(' NUMBER OF PARAMETERS LESS THAN 1 OR GREATER', 1 'THAN NUMBER OF OBSERVATIONS.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.1 .AND. IDIG1.GE.1)THEN WRITE(ICOUT,650) 650 FORMAT(' NUMBER OR RESPONSE VARIABLES IS LESS THAN 1.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.2 .AND. IDIG4.GE.1)THEN WRITE(ICOUT,660) 660 FORMAT(' NUMBER OF OBSERVATIONS IN INDEPENDENT ', 1 'VARIABLES LESS THAN NUMBER OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,662) 662 FORMAT(' OBSERVATIONS IN DEDEPENDENT VARIABLE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.2 .AND. IDIG2.GE.2)THEN WRITE(ICOUT,665) 665 FORMAT(' BAD DIMENSION FOR LDWE, LD2WE, LDWD OR LD2WD.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.2 .AND. IDIG2.GE.1)THEN WRITE(ICOUT,670) 670 FORMAT(' BAD DIMENSION FOR LDIFX, LDSCLD, OR LDRHO.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.3 .AND. IDIG4.GE.1)THEN WRITE(ICOUT,680) 680 FORMAT(' STPB OR STPD INCORRECT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.3 .AND. IDIG3.GE.1)THEN WRITE(ICOUT,690) 690 FORMAT(' SCLB OR SCLD INCORRECT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.3 .AND. IDIG2.GE.1)THEN WRITE(ICOUT,700) 700 FORMAT(' WEIGHTS FOR RESPONSE VARIABLE INCORRECT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.3 .AND. IDIG1.GE.1)THEN WRITE(ICOUT,710) 710 FORMAT(' WEIGHTS FOR INDPENDENT VARIABLES INCORRECT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.4)THEN WRITE(ICOUT,720) 720 FORMAT(' ERROR IN DERIVATIVES.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.5)THEN WRITE(ICOUT,730) 730 FORMAT(' LAST FUNCTION EVALUATION INCORRECT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ELSEIF(IDIG5.EQ.6)THEN WRITE(ICOUT,740) 740 FORMAT(' NUMERICAL ERROR ENCOUNTERED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,742) 742 FORMAT(' SOME POSSIBLE CAUSES:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,744) 744 FORMAT(' 1. USER INPUT POSSIBLY INCORRECT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,746) 746 FORMAT(' 2. POOR CHOICE OF WEIGHTS OR SCALING.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF ENDIF C CALL DWINF 1 (N,M,NP,NQ,LDWE,LD2WE,ISODR, 1 DELTAI, EPSI, XPLUSI, FNI, SDI, VCVI, 1 RVARI, WSSI, WSSDEI, WSSEPI, RCONDI, ETAI, 1 OLMAVI, TAUI, ALPHAI, ACTRSI, PNORMI, RNORSI, PRERSI, 1 PARTLI, SSTOLI, TAUFCI, EPSMAI, 1 BETA0I, BETACI, BETASI, BETANI, SI, SSI, SSFI, QRAUXI, UI, 1 FSI, FJACBI, WE1I, DIFFI, 1 DELTSI, DELTNI, TI, TTI, OMEGAI, FJACDI, 1 WRK1I, WRK2I, WRK3I, WRK4I, WRK5I, WRK6I, WRK7I, 1 LWKMN) C CALL DIWINF 1 (M,NP,NQ, 1 MSGBI, MSGDI, IFIX2I, ISTOPI, 1 NNZWI, NPPI, IDFI, 1 JOBI, IPRINI, LUNERI, LUNRPI, 1 NROWI, NTOLI, NETAI, 1 MAXITI, NITERI, NFEVI, NJEVI, INT2I, IRANKI, LDTTI, 1 LIWKMN) C C **************************************************** C ** STEP 81-- ** C ** WRITE INFO OUT TO FILES-- ** C ** 1) DPST1F.DAT--COEF COEFSD ** C ** 2) DPST2F.DAT--PARAMETER COVARIANCE MATRIX ** C ** 3) DPST3F.DAT--PREDICTED X (X+DELTA) ** C ** 4) DPST4F.DAT--ERROR IN X (DELTA) ** C **************************************************** C 8100 CONTINUE C ISTEPN='81' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ORT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO935L=1,NQ DO930I=1,N RES2(I+(L-1)*N)=REAL(WORK(EPSI-1+I+(L-1)*N)) PRED2(I+(L-1)*N)=REAL(WORK(FNI-1+I+(L-1)*N)) 930 CONTINUE 935 CONTINUE C DO940I=1,N WRITE(IOUNI3,'(20(E15.7,1X))') (WORK(XPLUSI-1+I+(J-1)*N),J=1,M) WRITE(IOUNI4,'(20(E15.7,1X))') (WORK(DELTAI-1+I+(J-1)*N),J=1,M) 940 CONTINUE C RESVAR=REAL(WORK(RVARI)) RESSD=0.0 IF(RESVAR.GT.0.0)RESSD=SQRT(RESVAR) RESDF=REAL(IWORK(IDFI)) DO950I=1,NP DO955J=1,NP WORK(VCVI-1+I+(J-1)*N)=DBLE(RESVAR)*WORK(VCVI-1+I+(J-1)*NP) 955 CONTINUE WRITE(IOUNI2,'(20(E15.7,1X))') 1 (REAL(WORK(VCVI-1+I+(J-1)*NP)),J=1,NP) 950 CONTINUE C DO8110I=1,NP PARAM3(I)=REAL(BETA(I)) ASD=REAL(WORK(SDI-1+I)) WRITE(IOUNI1,8111)PARAM3(I),ASD,IPARN3(I),IPARN4(I) 8111 FORMAT(E15.7,1X,E15.7,10X,A4,A4) 8110 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO8119 WRITE(ICOUT,8112) 8112 FORMAT(6X,'COEF AND SD(COEF) WRITTEN TO FILE DPST1F.DAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8113) 8113 FORMAT(6X,'PARAMETER VARIANCE-COVARIANCE MATRIX WRITTEN TO ', 1 'FILE DPST2F.DAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8114) 8114 FORMAT(6X,'PREDICTED INDEPENDENT VARIABLE ARRAY WRITTEN TO ', 1 'FILE DPST3F.DAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8116) 8116 FORMAT(6X,'ERROR IN INDPENDENT VARIABLE ARRAY WRITTEN TO ', 1 'FILE DPST4F.DAT') CALL DPWRST('XXX','BUG ') 8119 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO8129 8129 CONTINUE C C ************************************** C ** STEP 82-- ** C ** CLOSE THE STORAGE FILES. ** C ************************************** C 8200 CONTINUE C ISTEPN='82' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IENDF3='OFF' IREWI3='ON' CALL DPCLFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1IENDF3,IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1IENDF4,IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'ORT2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPORT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOSM(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ORDER STATISTIC MEDIANS FOR C UNIFORM DISTRIBUTION C NORMAL DISTRIBUTION C HALFNORMAL DISTRIBUTION C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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--91/11 C ORIGINAL VERSION--OCTOBER 1991. C UPDATED --MAY 1993. EV1, EV2, WEIBULL C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASLE CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 NEWCOL CHARACTER*4 ICASEQ CHARACTER*4 ILEFT CHARACTER*4 ILEFT2 C CCCCC THE FOLLOWING 4 LINES WERE ADDED MAY 1993 CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPOS' ISUBN2='M ' 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 IFOUND='YES' C NS2=0 C C *********************************************** C ** TREAT THE ORDER STATISTIC MEDIANS CASE ** C ** 1) FOR A FULL VARIABLE, OR ** C ** 2) FOR PART OF A VARIABLE. ** C *********************************************** C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASLE,IBUGA3,IBUGQ 52 FORMAT('ICASLE,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' NEWCOL='NO' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=3 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************************************** C ** STEP 3-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILEFT IS THE NAME OF THE VARIABLE * C ** ON THE LEFT. * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C ** NOTE THAT ICOLL IS THE DATA COLUMN (1 TO 12) * C ** FOR THE NAME OF THE LEFT. * C **************************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC ILEFT=IHOL(2) CCCCC ILEFT2=IHOL2(2) ILEFT=IHARG(1) ILEFT2=IHARG2(1) DO310I=1,NUMNAM I2=I IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO329 IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO380 310 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)GOTO320 GOTO330 C 320 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('***** ERROR IN DPOSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,322) 322 FORMAT(' THE NUMBER OF VARIABLE AND/OR PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)MAXNAM 323 FORMAT(' NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ', 1I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,324) 324 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,326) 326 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,327) 327 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,328) 328 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 329 CONTINUE ILISTL=I2 GOTO330 C 330 CONTINUE NLEFT=0 ICOLL=NUMCOL+1 IF(ICOLL.GT.MAXCOL)GOTO340 GOTO390 C 340 CONTINUE WRITE(ICOUT,341) 341 FORMAT('***** ERROR IN DPOSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,342) 342 FORMAT(' THE NUMBER OF DATA COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,343)MAXCOL 343 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,344) 344 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,345) 345 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,346) 346 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,347) 347 FORMAT(' AND THEN OVERWRITE SOME COLUMNS. EXAMPLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,348) 348 FORMAT(' IF LET X(I) = 3.14 FAILED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,349) 349 FORMAT(' THEN ONE MIGHT ENTER NAME X 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,350) 350 FORMAT(' (THEREBY EQUATING THE NAME X WITH COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,351) 351 FORMAT(' FOLLOWED BY LET X = 3.14') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,352) 352 FORMAT(' (WHICH WILL ACTUALLY OVERWRITE COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,353) 353 FORMAT(' WITH THE NUMERIC CONSTANTS 3.14)') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 380 CONTINUE ILISTL=I2 ICOLL=IVALUE(ILISTL) NLEFT=IN(ILISTL) C 390 CONTINUE C C ***************************************** C ** STEP 6-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER) ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='6' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO670 DO610J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO620 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO620 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO630 610 CONTINUE GOTO680 C 620 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO680 C 630 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO680 C 670 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,671) 671 FORMAT('***** INTERNAL ERROR IN DPOSM') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,672) 672 FORMAT(' AT BRANCH POINT 5081--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,673) 673 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,674) 674 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,675)NUMARG 675 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,676) 676 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,677)(IANS(I),I=1,IWIDTH) 677 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 680 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO690 WRITE(ICOUT,681)NUMARG,ILOCQ,ICASEQ 681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') C 690 CONTINUE C C ****************************************************** C ** STEP 7-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE ** C ** (BASED ON THE QUALIFIER); ** C ** DETERMINE THE NUMBER (= NOSM) ** C ** OF ORDER STATISTIC MEDIANS TO BE GENERATED. C ** NOTE THAT THE VARIABLE NIISUB ** C ** IS THE LENGTH OF THE RESULTING ** C ** VARIABLE ISUB(.). ** C ** NOTE THAT DPFOR AUTOMATICALLY EXTENDS ** C ** THE INPUT LENGTH OF ISUB(.) IF NECESSARY. ** C ** (HENCE THE REDEFINITION OF NIISUB TO NINEW ** C ** AFTER THE CALL TO DPFOR. ** C ****************************************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO710 IF(ICASEQ.EQ.'SUBS')GOTO720 IF(ICASEQ.EQ.'FOR')GOTO730 C 710 CONTINUE IF(NEWNAM.EQ.'NO')NIISUB=NLEFT IF(NEWNAM.EQ.'YES')NIISUB=MAXN DO715I=1,NIISUB ISUB(I)=1 715 CONTINUE NOSM=NIISUB GOTO750 C 720 CONTINUE NIISUB=MAXN CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR) NOSM=NS GOTO750 C 730 CONTINUE IF(NEWNAM.EQ.'NO')NIISUB=NLEFT IF(NEWNAM.EQ.'YES')NIISUB=MAXN CALL DPFOR(NIISUB,NINEW,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NIISUB=NINEW NOSM=NS GOTO750 C 750 CONTINUE C C ****************************************** C ** STEP 8-- ** C ** GENERATE NOSM ORDER ** C ** STATISTIC MEDIANS. ** C ** STORE THEM TEMPORARILY IN ** C ** THE VECTOR Y(.). ** C ****************************************** C ISTEPN='8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL UNIMED(NOSM,Y) C IF(ICASLE.EQ.'UOSM')GOTO890 IF(ICASLE.EQ.'NOSM')GOTO820 IF(ICASLE.EQ.'HOSM')GOTO830 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1993 IF(ICASLE.EQ.'E1OM'.OR.ICASLE.EQ.'E2OM'.OR.ICASLE.EQ.'WOSM')THEN IHP='GAMM' IHP2='A ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GAMMA=VALUE(ILOCP) C IF(GAMMA.GT.0)GOTO1590 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1511) 1511 FORMAT('***** ERROR IN DPOSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1512) 1512 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1513) 1513 FORMAT(' FOR THE EV1/EV2/WEIBULL DISTRIBUTIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1514) 1514 FORMAT(' MUST BE STRICTLY LARGER THAN 0;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1515) 1515 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1516)GAMMA 1516 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1590 CONTINUE ENDIF C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1993 IF(ICASLE.EQ.'E1OM')GOTO840 IF(ICASLE.EQ.'E2OM')GOTO850 IF(ICASLE.EQ.'WOSM')GOTO860 C 820 CONTINUE DO821I=1,NOSM CALL NORPPF(Y(I),Y(I)) 821 CONTINUE GOTO890 C 830 CONTINUE DO831I=1,NOSM CALL HFNPPF(Y(I),Y(I)) 831 CONTINUE GOTO890 C 840 CONTINUE DO841I=1,NOSM CALL EV1PPF(Y(I),MINMAX,Y(I)) 841 CONTINUE GOTO890 C 850 CONTINUE DO851I=1,NOSM CALL EV2PPF(Y(I),GAMMA,MINMAX,Y(I)) 851 CONTINUE GOTO890 C 860 CONTINUE DO861I=1,NOSM CALL WEIPPF(Y(I),GAMMA,MINMAX,Y(I)) 861 CONTINUE GOTO890 C 890 CONTINUE C C *********************************************************** C ** STEP 8-- ** C ** IF CALLED FOR (THAT IS, IF IBUGA3 IS ON), ** C ** PRINT OUT THE INTERMEDIATE VARIABLE Y(.). ** C ** THIS IS USEFUL FOR DIAGNOSTIC PURPOSES ** C ** IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE. ** C *********************************************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA3.EQ.'OFF')GOTO2090 WRITE(ICOUT,2051) 2051 FORMAT('OUTPUT FROM MIDDLE OF DPOSM AFTER UNIMED ', 1'HAS BEEN CALLED--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2052)NOSM 2052 FORMAT('NOSM = ',I8) CALL DPWRST('XXX','BUG ') IF(NOSM.LE.0)GOTO2090 DO2054I=1,NOSM WRITE(ICOUT,2055)I,Y(I) 2055 FORMAT('I,Y(I) = ',I8,F12.5) CALL DPWRST('XXX','BUG ') 2054 CONTINUE C 2090 CONTINUE C C ****************************************************** C ** STEP 9-- ** C ** COPY THE ORDER STATISTIC MEDIANS ** C ** FROM THE INTERMEDIATE VECTOR Y(.) ** C ** TO THE APPROPRIATE COLUMN ** C ** (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR) ** C ** IN THE INTERNAL DATAPLOT DATA TABLE. ** C ****************************************************** C ISTEPN='10' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NS2=0 DO2100I=1,NIISUB IJ=MAXN*(ICOLL-1)+I IF(ISUB(I).EQ.0)GOTO2100 NS2=NS2+1 IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2) IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2) IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2) IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2) IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2) IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2) IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2) IF(NS2.EQ.1)IROW1=I IROWN=I 2100 CONTINUE C C ******************************************* C ** STEP 10-- ** C ** CARRY OUT THE LIST UPDATING AND ** C ** GENERATE THE INFORMATIVE PRINTING. ** C ******************************************* C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO')NINEW=NLEFT IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=MAXN IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN C IHNAME(ILISTL)=ILEFT IHNAM2(ILISTL)=ILEFT2 IUSE(ILISTL)='V' IVALUE(ILISTL)=ICOLL VALUE(ILISTL)=ICOLL IN(ILISTL)=NINEW C CCCCC IUSE(ICOLL)='V' CCCCC IVALUE(ICOLL)=ICOLL CCCCC VALUE(ICOLL)=ICOLL CCCCC IN(ICOLL)=NINEW C IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1 C DO4100J4=1,NUMNAM IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO4105 GOTO4100 4105 CONTINUE IUSE(J4)='V' IVALUE(J4)=ICOLL VALUE(J4)=ICOLL IN(J4)=NINEW 4100 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO4059 IF(IFEEDB.EQ.'OFF')GOTO4059 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4011)ILEFT,ILEFT2,NS2 4011 FORMAT('THE NUMBER OF VALUES GENERATED FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IJ=MAXN*(ICOLL-1)+IROW1 IF(ICOLL.LE.MAXCOL)WRITE(ICOUT,4021)ILEFT,ILEFT2,V(IJ), 1IROW1 IF(ICOLL.LE.MAXCOL)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP1)WRITE(ICOUT,4021)ILEFT,ILEFT2,PRED(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP2)WRITE(ICOUT,4021)ILEFT,ILEFT2,RES(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP2)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP3)WRITE(ICOUT,4021)ILEFT,ILEFT2,YPLOT(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP3)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP4)WRITE(ICOUT,4021)ILEFT,ILEFT2,XPLOT(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP4)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP5)WRITE(ICOUT,4021)ILEFT,ILEFT2,X2PLOT(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP5)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP6)WRITE(ICOUT,4021)ILEFT,ILEFT2,TAGPLO(IROW1), 1IROW1 4021 FORMAT('THE FIRST COMPUTED VALUE OF ',A4,A4, 1' = ',E15.7,' (ROW ',I6,')') IF(ICOLL.EQ.MAXCP6)CALL DPWRST('XXX','BUG ') C IJ=MAXN*(ICOLL-1)+IROWN IF(ICOLL.LE.MAXCOL.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,V(IJ),IROWN 4031 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ',A4,A4, 1' = ',E15.7,' (ROW ',I6,')') IF(ICOLL.LE.MAXCOL.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP1.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN IF(ICOLL.EQ.MAXCP1.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP2.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN IF(ICOLL.EQ.MAXCP2.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP3.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP3.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP4.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP4.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP5.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP5.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP6.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN IF(ICOLL.EQ.MAXCP6.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(NS2.NE.1)GOTO4090 WRITE(ICOUT,4041) 4041 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4042) 4042 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.') CALL DPWRST('XXX','BUG ') 4090 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4112)ILEFT,ILEFT2,ICOLL 4112 FORMAT('THE CURRENT COLUMN FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4113)ILEFT,ILEFT2,NINEW 4113 FORMAT('THE CURRENT LENGTH OF ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 4059 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 DPOSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASLE,IBUGA3,IBUGQ 9013 FORMAT('ICASLE,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NS2 9015 FORMAT('NS2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NS,NIISUB,NOSM 9016 FORMAT('NS,NIISUB,NOSM = ',I8,I8,I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOVA2(X1,Y1,X2,Y2,X3,Y3, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--DRAW A OVAL C WITH ONE END OF THE MAJOR AXIS AT (X1,Y1) C WITH ONE END OF THE MINOR AXIS AT (X2,Y2) C AND THE OTHER END OF MAJOR AXIS AT (X3,Y3). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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.'OVA2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOVA2--') 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 OVAL ** C ********************************* C PI=3.1415926 C C **************************************************** C ** STEP 1.1-- ** C ** FIND THE ANGLE OF ROTATION OF THE MAJOR AXIS ** C ** FIND THE RADIUS OF THE MAJOR AXIS ** C **************************************************** C DELX=X3-X1 DELY=Y3-Y1 ALEN=0.0 TERM=DELX**2+DELY**2 IF(TERM.GT.0.0)ALEN=SQRT(TERM) A=ALEN/2.0 C IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX) IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=PI/2.0 IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-PI/2.0 IF(IBUGG4.EQ.'ON')WRITE(ICOUT,776)ALEN,A,THETA 776 FORMAT('ALEN,A,THETA = ',3E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *********************************** C ** STEP 1.2-- ** C ** FIND THE CENTER OF THE OVAL ** C *********************************** C XCENT=(X1+X3)/2.0 YCENT=(Y1+Y3)/2.0 IF(IBUGG4.EQ.'ON')WRITE(ICOUT,777)XCENT,YCENT 777 FORMAT('XCENT,YCENT = ',2E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ***************************************** C ** STEP 1.3-- ** C ** FIND THE RADIUS OF THE MINOR AXIS ** C ***************************************** C DELX2=2.0*(X2-XCENT) DELY2=2.0*(Y2-YCENT) ALENMI=0.0 TERM=DELX2**2+DELY2**2 IF(TERM.GT.0.0)ALENMI=SQRT(TERM) B=ALENMI/2.0 IF(IBUGG4.EQ.'ON')WRITE(ICOUT,778)ALENMI,B 778 FORMAT('ALENMI,B = ',2E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ********************* C ** STEP 1.4-- ** C ** DRAW THE OVAL ** C ********************* C K=0 C X=0 Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C C ****************************************** C ** STEP 1.5-- ** C ** DRAW THE UPPER LEFT QUARTER-CIRCLE ** C ****************************************** C X=0 Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX3=XP AJY3=YP X=(1.0-SQRT(0.5))*B Y=SQRT(0.5)*B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX4=XP AJY4=YP X=B Y=B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX5=XP AJY5=YP CALL DPOVA3(AJX3,AJY3,AJX4,AJY4,AJX5,AJY5,PX,PY,K) C C ************************************* C ** STEP 1.6-- ** C ** DRAW THE STRAIGHT TOP SECTION ** C ************************************* C X=ALEN-B Y=B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C C ******************************************* C ** STEP 1.7-- ** C ** DRAW THE UPPER-RIGHT QUARTER-CIRCLE ** C ******************************************* C X=ALEN-B Y=B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX3=XP AJY3=YP X=ALEN-((1.0-SQRT(0.5))*B) Y=SQRT(0.5)*B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX4=XP AJY4=YP X=ALEN Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX5=XP AJY5=YP CALL DPOVA3(AJX3,AJY3,AJX4,AJY4,AJX5,AJY5,PX,PY,K) C C ******************************************* C ** STEP 1.8-- ** C ** DRAW THE LOWER-RIGHT QUARTER-CIRCLE ** C ******************************************* C X=ALEN Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX3=XP AJY3=YP X=ALEN-((1.0-SQRT(0.5))*B) Y=-SQRT(0.5)*B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX4=XP AJY4=YP X=ALEN-B Y=-B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX5=XP AJY5=YP CALL DPOVA3(AJX3,AJY3,AJX4,AJY4,AJX5,AJY5,PX,PY,K) C C **************************************** C ** STEP 1.9-- ** C ** DRAW THE BOTTOM STRAIGHT SECTION ** C **************************************** C X=B Y=-B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C C ****************************************** C ** STEP 1.10-- ** C ** DRAW THE LOWER-LEFT QUARTER-CIRCLE ** C ****************************************** C X=B Y=-B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX3=XP AJY3=YP X=(1.0-SQRT(0.5))*B Y=-SQRT(0.5)*B CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX4=XP AJY4=YP X=0 Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) AJX5=XP AJY5=YP CALL DPOVA3(AJX3,AJY3,AJX4,AJY4,AJX5,AJY5,PX,PY,K) C NP=K C C *********************** C ** STEP 2-- ** C ** FILL THE FIGURE ** C ** (IF CALLED FOR) ** C *********************** C IF(IREFSW(1).EQ.'OFF')GOTO2190 IPATT=IREPTY(1) IPATT2='SOLI' PTHICK=PREPTH(1) PXGAP=PREPSP(1) PYGAP=PREPSP(1) ICOLF=IREFCO(1) ICOLP=IREPCO(1) CALL DPFIRE(PX,PY,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 2190 CONTINUE C C *************************** C ** STEP 3-- ** C ** DRAW OUT THE FIGURE ** C *************************** C IPATT=ILINPA(1) PTHICK=PLINTH(1) ICOL=ILINCO(1) IFLAG='ON' CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OVA2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOVA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)DELX,DELY 9012 FORMAT('DELX,DELY = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)XCENT,YCENT,A,B 9013 FORMAT('XCENT,YCENT,A,B = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NP 9014 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)I,PX(I),PY(I) 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOVA3(X1,Y1,X2,Y2,X3,Y3,PX,PY,K) C C PURPOSE--DRAW AN ARC (AS PART OF AN OVAL) C WITH ONE END OF THE ARC AT (X1,Y1) C SOME MIDDLE POINT AT (X2,Y2), C AND THE OTHER END OF THE ARC AT (X3,Y3). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1981. C UPDATED --MAY 1982. C C-----NON-COMMON VARIABLES------------------------------------- C DIMENSION PX(*) DIMENSION PY(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OVA3')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOVA3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)X1,Y1 53 FORMAT('X1,Y1 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)X2,Y2 54 FORMAT('X2,Y2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)X3,Y3 55 FORMAT('X3,Y3 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)K 56 FORMAT('K = ',I8) 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 ARC ** C ********************************* C PI=3.1415926 C THETA=0.0 THETA1=0.0 THETA2=0.0 THETA3=0.0 C C **************************************************************** C ** STEP 1.1-- ** C ** COMPUTE THE INTERCEPT AND SLOPE OF THE LINE ** C ** THROUGH THE MIDPOINT OF POINTS 1 AND 2 ** C ** AND PERPENDICULAR TO THE SEGMENT BETWEEN POINTS 1 AND 2. ** C **************************************************************** C DELX12=X2-X1 DELY12=Y2-Y1 C IF(DELX12.EQ.0.0)GOTO711 IF(DELY12.EQ.0.0)GOTO712 GOTO713 C 711 CONTINUE AM12=CPUMAX B12=CPUMAX AM12P=0.0 B12P=Y1 GOTO715 C 712 CONTINUE AM12=0.0 B12=Y1 AM12P=CPUMAX B12P=CPUMAX GOTO715 C 713 CONTINUE AM12=DELY12/DELX12 B12=-AM12*X1+Y1 X12=(X1+X2)/2.0 Y12=(Y1+Y2)/2.0 AM12P=-1.0/AM12 B12P=-AM12P*X12+Y12 GOTO715 C 715 CONTINUE IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1WRITE(ICOUT,716)DELX12,DELY12,B12,AM12,B12P,AM12P 716 FORMAT('DELX12,DELY12,B12,AM12,B12P,AM12P = ',6E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1CALL DPWRST('XXX','BUG ') C C **************************************************************** C ** STEP 1.2-- ** C ** COMPUTE THE INTERCEPT AND SLOPE OF THE LINE ** C ** THROUGH THE MIDPOINT OF POINTS 2 AND 3 ** C ** AND PERPENDICULAR TO THE SEGMENT BETWEEN POINTS 2 AND 3. ** C **************************************************************** C DELX23=X3-X2 DELY23=Y3-Y2 C IF(DELX23.EQ.0.0)GOTO721 IF(DELY23.EQ.0.0)GOTO722 GOTO723 C 721 CONTINUE AM23=CPUMAX B23=CPUMAX AM23P=0.0 B23P=Y2 GOTO725 C 722 CONTINUE AM23=0.0 B23=Y2 AM23P=CPUMAX B23P=CPUMAX GOTO725 C 723 CONTINUE AM23=DELY23/DELX23 B23=-AM23*X2+Y2 X23=(X2+X3)/2.0 Y23=(Y2+Y3)/2.0 AM23P=-1.0/AM23 B23P=-AM23P*X23+Y23 GOTO725 C 725 CONTINUE IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1WRITE(ICOUT,726)DELX23,DELY23,B23,AM23,B23P,AM23P 726 FORMAT('DELX23,DELY23,B23,AM23,B23P,AM23P = ',6E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1CALL DPWRST('XXX','BUG ') C C *************************************************** C ** STEP 1.3-- ** C ** COMPUTE THE COORDINATES OF THE CENTER POINT ** C ** OF THE CIRCLE DEFINED BY THE 3 ARC POINTS. ** C *************************************************** C ANUM=-(B12P-B23P) ADEN=AM12P-AM23P XCENT=CPUMAX IF(ADEN.NE.0.0)XCENT=ANUM/ADEN YCENT=AM12P*XCENT+B12P IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1WRITE(ICOUT,731)ANUM,ADEN,XCENT,YCENT 731 FORMAT('ANUM,ADEN,XCENT,YCENT = ',4E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1CALL DPWRST('XXX','BUG ') C C **************************************************** C ** STEP 1.4-- ** C ** COMPUTE THE ANGLE OF ROTATION OF THE FIGURE. ** C **************************************************** C DELX=X3-X1 DELY=Y3-Y1 C IF(ABS(DELX).GE.0.00001.AND.DELX.LT.0.0) 1THETA=PI+ATAN(DELY/DELX) IF(ABS(DELX).GE.0.00001.AND.DELX.GT.0.0) 1THETA=ATAN(DELY/DELX) C IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0) 1THETA=1.5*(PI/2.0) IF(ABS(DELX).LT.0.00001.AND.DELX.EQ.0.0) 1THETA=PI/2.0 IF(ABS(DELX).LT.0.00001.AND.DELY.GT.0.0) 1THETA=PI/2.0 C IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1WRITE(ICOUT,741)DELX,DELY,THETA 741 FORMAT('DELX,DELY,THETA = ',3E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1CALL DPWRST('XXX','BUG ') C C *********************************************************** C ** STEP 1.5-- ** C ** COMPUTE THE RADIUS OF THE CIRCLE. ** C ** COMPUTE THE ANGLE FROM THE CENTER POINT TO POINT 1. ** C *********************************************************** C DELXC1=2.0*(X1-XCENT) DELYC1=2.0*(Y1-YCENT) ALEN=0.0 TERM=DELXC1**2+DELYC1**2 IF(TERM.GT.0.0)ALEN=SQRT(TERM) R=ALEN/2.0 IF(ABS(DELXC1).GE.0.00001.AND.DELXC1.GE.0.0) 1THETA1=ATAN(DELYC1/DELXC1) IF(ABS(DELXC1).GE.0.00001.AND.DELXC1.LT.0.0) 1THETA1=PI+ATAN(DELYC1/DELXC1) IF(ABS(DELXC1).LT.0.00001.AND.DELYC1.GE.0.0) 1THETA1=PI/2.0 IF(ABS(DELXC1).LT.0.00001.AND.DELYC1.LT.0.0) 1THETA1=1.5*(PI/2.0) IF(THETA1.LT.0.0)THETA1=THETA1+2.0*PI IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1WRITE(ICOUT,751)ALEN,R 751 FORMAT('ALEN,R = ',2E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1CALL DPWRST('XXX','BUG ') IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1WRITE(ICOUT,752)DELXC1,DELYC1,THETA1 752 FORMAT('DELXC1,DELYC1,THETA1 = ',3E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1CALL DPWRST('XXX','BUG ') C C *********************************************************** C ** STEP 1.6-- ** C ** COMPUTE THE ANGLE FROM THE CENTER POINT TO POINT 2. ** C *********************************************************** C DELXC2=2.0*(X2-XCENT) DELYC2=2.0*(Y2-YCENT) IF(ABS(DELXC2).GE.0.00001.AND.DELXC2.GE.0.0) 1THETA2=ATAN(DELYC2/DELXC2) IF(ABS(DELXC2).GE.0.00001.AND.DELXC2.LT.0.0) 1THETA2=PI+ATAN(DELYC2/DELXC2) IF(ABS(DELXC2).LT.0.00001.AND.DELYC2.GE.0.0) 1THETA2=PI/2.0 IF(ABS(DELXC2).LT.0.00001.AND.DELYC2.LT.0.0) 1THETA2=1.5*(PI/2.0) IF(THETA2.LT.0.0)THETA2=THETA2+2.0*PI IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1WRITE(ICOUT,761)DELXC2,DELYC2,THETA2 761 FORMAT('DELXC2,DELYC2,THETA2 = ',3E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1CALL DPWRST('XXX','BUG ') C C *********************************************************** C ** STEP 1.7-- ** C ** COMPUTE THE ANGLE FROM THE CENTER POINT TO POINT 3. ** C *********************************************************** C DELXC3=2.0*(X3-XCENT) DELYC3=2.0*(Y3-YCENT) IF(ABS(DELXC3).GE.0.00001.AND.DELXC3.GE.0.0) 1THETA3=ATAN(DELYC3/DELXC3) IF(ABS(DELXC3).GE.0.00001.AND.DELXC3.LT.0.0) 1THETA3=PI+ATAN(DELYC3/DELXC3) IF(ABS(DELXC3).LT.0.00001.AND.DELYC3.GE.0.0) 1THETA3=PI/2.0 IF(ABS(DELXC3).LT.0.00001.AND.DELYC3.LT.0.0) 1THETA3=1.5*(PI/2.0) IF(THETA3.LT.0.0)THETA3=THETA3+2.0*PI IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1WRITE(ICOUT,771)DELXC3,DELYC3,THETA3 771 FORMAT('DELXC3,DELYC3,THETA3 = ',3E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1CALL DPWRST('XXX','BUG ') C C ****************************** C ** STEP 1.8-- ** C ** COMPUTE THE ARC POINTS ** C ****************************** C K=K+1 PX(K)=X1 PY(K)=Y1 C IF(THETA1.LE.THETA3.AND.THETA3.LE.THETA2)GOTO3001 IF(THETA2.LE.THETA1.AND.THETA1.LE.THETA3)GOTO3002 IF(THETA3.LE.THETA1.AND.THETA1.LE.THETA2)GOTO3003 IF(THETA2.LE.THETA3.AND.THETA3.LE.THETA1)GOTO3004 GOTO3005 3001 CONTINUE THETA1=THETA1+2.0*PI GOTO3005 3002 CONTINUE THETA1=THETA1+2.0*PI THETA2=THETA2+2.0*PI GOTO3005 3003 CONTINUE THETA1=THETA1+2.0*PI GOTO3005 3004 CONTINUE THETA2=THETA2+2.0*PI THETA3=THETA3+2.0*PI GOTO3005 3005 CONTINUE IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1WRITE(ICOUT,3009)THETA1,THETA2,THETA3 3009 FORMAT('THETA1,THETA2,THETA3 = ',3E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'OVA3') 1CALL DPWRST('XXX','BUG ') C DELTHE=THETA3-THETA1 IMAX=101 AIMAX=IMAX DO3010I=1,IMAX AI=I P=(AI-1.0)/(AIMAX-1.0) PHI2=THETA1+P*DELTHE X=XCENT+R*COS(PHI2) Y=YCENT+R*SIN(PHI2) K=K+1 PX(K)=X PY(K)=Y 3010 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'IND2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOVA3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)K 9014 FORMAT('K = ',A4) CALL DPWRST('XXX','BUG ') DO9015I=1,K 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,9022)XCENT,YCENT,R 9022 FORMAT('XCENT,YCENT,R = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPOVAL(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 OVALS C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE INPUT COORDINATES DEFINE 3 SUCCESSIVE POINTS C AROUND THE OVAL--AT THE ENDS OF AXES. C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 3 C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*3 = 6. C NOTE--IF 4 NUMBERS ARE PROVIDED, C THEN THE DRAWN OVAL WILL GO C FROM THE LAST CURSOR POSITION C (ASSUMED TO BE AT ONE END OF MAJOR AXIS) C THROUGH THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE FIRST AND SECOND NUMBERS C (ASSUMED TO BE AT ONE END OF MINOR AXIS), C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE THIRD AND FOURTH NUMBERS C (ASSUMED TO BE AT THE OTHER END OF MAJOR AXIS), C AND THEN BACK TO THE OTHER END OF THE MINOR AXIS, C AND CONTINUING BACK THE START POINT TO CLOSE THE OVAL. C NOTE--IF 6 NUMBERS ARE PROVIDED, C THEN THE DRAWN OVAL WILL GO C FROM THE ABSOLUTE (X,Y) POSITION C AS RESULTING FORM THE FIRST AND SECOND NUMBERS C (ASSUMED TO BE AT ONE END OF MAJOR AXIS), C THROUGH THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE THIRD AND FOURTH NUMBERS C (ASSUMED TO BE AT ONE END OF MINOR AXIS), C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE FIFTH AND SIXTH NUMBERS C (ASSUMED TO BE AT THE OTHER END OF MAJOR AXIS), C AND THEN BACK TO THE OTHER END OF THE MINOR AXIS, C AND CONTINUING BACK THE START POINT TO CLOSE THE OVAL. C NOTE--AND SO FORTH FOR 10, 14, 18, ... NUMBERS. C INPUT ARGUMENTS--IHARG C --IARGT C --ARG C --NUMARG C --PXSTAR C --PYSTAR C OUTPUT ARGUMENTS--PXEND C --PYEND C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 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.'OVAL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPOVAL--') 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='OVAL' NUMPT=3 NUMPT2=2*NUMPT C C ******************************** C ** STEP 0-- ** C ** STEP THROUGH EACH DEVICE ** C ******************************** C IF(NUMDEV.LE.0)GOTO9000 DO8000IDEVIC=1,NUMDEV C IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 C IMANUF=IDMANU(IDEVIC) IMODEL=IDMODE(IDEVIC) IMODE2=IDMOD2(IDEVIC) IMODE3=IDMOD3(IDEVIC) IGCONT=IDCONT(IDEVIC) IGCOLO=IDCOLO(IDEVIC) CCCCC ADD FOLLOWING LINE MARCH 1997. IGFONT=IDFONT(IDEVIC) NUMVPP=IDNVPP(IDEVIC) NUMHPP=IDNHPP(IDEVIC) ANUMVP=NUMVPP ANUMHP=NUMHPP C AUGUST 1988. ADD OFFSET VARIABLE IOFFSV=IDNVOF(IDEVIC) IOFFSH=IDNHOF(IDEVIC) C IGUNIT=IDUNIT(IDEVIC) C C ************************************ C ** STEP 1-- ** C ** CARRY OUT OPENING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C CALL DPOPDE C IBELSW='OFF' NUMRIN=0 IERASW='OFF' IBACCO='JUNK' C CALL DPOPPL(IGRASW, 1IBELSW,NUMRIN,IERASW, 1IBACCO) C C ***************************************** C ** STEP 2-- ** C ** SEARCH FOR COMMAND SPECIFICATIONS ** C ***************************************** C IF(NUMARG.GE.2.AND. 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1GOTO1111 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1113 GOTO1130 C 1111 CONTINUE ITYPEO='ABSO' ILOCFN=1 GOTO1119 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='RELA' ILOCFN=2 GOTO1119 1119 CONTINUE C IF(ILOCFN.GT.NUMARG)GOTO1129 DO1120I=ILOCFN,NUMARG IF(IARGT(I).EQ.'NUMB')GOTO1120 GOTO1129 1120 CONTINUE IFOUND='YES' GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPOVAL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW AN OVAL ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH ONE END OF MAJOR AXIS AT THE POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' ONE END OF THE MINOR AXIS AT THE POINT 30 10') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138) 1138 FORMAT(' AND WITH THE OTHER END OF THE MAJOR AXIS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1139) 1139 FORMAT(' AT THE POINT 40 20') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' OVAL 20 20 30 10 40 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' OVAL ABSOLUTE 20 20 30 10 40 20 ') CALL DPWRST('XXX','BUG ') GOTO9000 1149 CONTINUE C C **************************** C ** STEP 3-- ** C ** DRAW OUT THE LINE(S) ** C **************************** C NUMNUM=NUMARG-ILOCFN+1 IF(NUMNUM.LT.NUMPT2)GOTO1151 GOTO1152 C 1151 CONTINUE J=ILOCFN-1 X1=PXSTAR Y1=PYSTAR GOTO1159 C 1152 CONTINUE J=ILOCFN IF(J.GT.NUMARG)GOTO1190 X1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) J=J+1 IF(J.GT.NUMARG)GOTO1190 Y1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) GOTO1159 1159 CONTINUE C 1160 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X2=X1+X2 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 C 1170 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X3=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X3,X3,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X3=X2+X3 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y3=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y3,Y3,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y3=Y2+Y3 C CALL DPOVA2(X1,Y1,X2,Y2,X3,Y3, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C X1=X3 Y1=Y3 C GOTO1160 1190 CONTINUE C PXEND=X3 PYEND=Y3 C C ************************************ C ** STEP 4-- ** C ** CARRY OUT CLOSING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C ICOPSW='OFF' NUMCOP=0 CALL DPCLPL(ICOPSW,NUMCOP, 1PGRAXF,PGRAYF, 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) C CALL DPCLDE C 8000 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OVAL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPOVAL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILOCFN,NUMNUM 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3 9013 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PXSTAR,PYSTAR 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)PXEND,PYEND 9016 FORMAT('PXEND,PYEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IFIG 9017 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)IFOUND 9027 FORMAT('IFOUND = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGD2,IERROR 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPACO(IHARG,NUMARG,IDEFPC,MAXPAT,IPATCO, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN COLORS. C THESE ARE LOCATED IN THE VECTOR IPATCO(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFPC C --MAXPAT C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IPATCO (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-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 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFPC CHARACTER*4 IPATCO 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 IPATCO(*) 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='DPPA' ISUBN2='CO ' C NUMPAT=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 DPPACO--') 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)MAXPAT,NUMPAT 53 FORMAT('MAXPAT,NUMPAT = ',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)IDEFPC 55 FORMAT('IDEFPC = ',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)IPATCO(1) 70 FORMAT('IPATCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IPATCO(I) 76 FORMAT('I,IPATCO(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)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IDEFPC IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMPAT=1 IPATCO(1)=IDEFPC GOTO1270 C 1220 CONTINUE NUMPAT=NUMARG-1 IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT DO1225I=1,NUMPAT J=I+1 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEFPC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFPC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPC IPATCO(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMPAT WRITE(ICOUT,1276)I,IPATCO(I) 1276 FORMAT('PATTERN COLOR ',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 NUMPAT=MAXPAT IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEFPC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFPC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPC DO1315I=1,NUMPAT IPATCO(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)IPATCO(I) 1316 FORMAT('ALL PATTERN COLORS 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 DPPACO--') 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)MAXPAT,NUMPAT 9013 FORMAT('MAXPAT,NUMPAT = ',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)IDEFPC 9015 FORMAT('IDEFPC = ',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)IPATCO(1) 9030 FORMAT('IPATCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IPATCO(I) 9036 FORMAT('I,IPATCO(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPAHE(IHARG,IARGT,ARG,NUMARG,PDEFPH,MAXPAT,PPATHE, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN HEIGHTS. C THESE ARE LOCATED IN THE VECTOR PPATHE(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEFPH C --MAXPAT C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PPATHE (A FLOATING POINT VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-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 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) DIMENSION PPATHE(*) 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='DPPA' ISUBN2='HE ' C NUMPAT=0 IHOLD1='-999' HOLD1=-999.0 HOLD2=-999.0 C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPAHE--') 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)MAXPAT,NUMPAT 53 FORMAT('MAXPAT,NUMPAT = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)PDEFPH 55 FORMAT('PDEFPH = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)PPATHE(1) 70 FORMAT('PPATHE(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PPATHE(I) 76 FORMAT('I,PPATHE(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=' ' IF(IHARG(2).EQ.'ALL')HOLD1=PDEFPH IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMPAT=1 PPATHE(1)=PDEFPH GOTO1270 C 1220 CONTINUE NUMPAT=NUMARG-1 IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT DO1225I=1,NUMPAT J=I+1 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFPH IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPH IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPH IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPH PPATHE(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMPAT WRITE(ICOUT,1276)I,PPATHE(I) 1276 FORMAT('PATTERN HEIGHT ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMPAT=MAXPAT HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFPH IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPH IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPH IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPH DO1315I=1,NUMPAT PPATHE(I)=HOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)PPATHE(I) 1316 FORMAT('ALL PATTERN HEIGHTS 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 DPPAHE--') 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)MAXPAT,NUMPAT 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PDEFPH 9015 FORMAT('PDEFPH = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)PPATHE(1) 9030 FORMAT('PPATHE(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PPATHE(I) 9036 FORMAT('I,PPATHE(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPALI(IHARG,NUMARG,IDEFPL,MAXPAT,IPATLI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN LINE TYPES. C THESE ARE LOCATED IN THE VECTOR IPATLI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFPL C --MAXPAT C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IPATLI (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-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 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFPL CHARACTER*4 IPATLI 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 IPATLI(*) 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='DPPA' ISUBN2='LI ' C NUMPAT=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 DPPALI--') 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)MAXPAT,NUMPAT 53 FORMAT('MAXPAT,NUMPAT = ',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)IDEFPL 55 FORMAT('IDEFPL = ',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)IPATLI(1) 70 FORMAT('IPATLI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IPATLI(I) 76 FORMAT('I,IPATLI(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)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=' ' IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMPAT=1 IPATLI(1)=' ' GOTO1270 C 1220 CONTINUE NUMPAT=NUMARG-1 IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT DO1225I=1,NUMPAT J=I+1 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPL IPATLI(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMPAT WRITE(ICOUT,1276)I,IPATLI(I) 1276 FORMAT('PATTERN LINE ',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 NUMPAT=MAXPAT IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPL DO1315I=1,NUMPAT IPATLI(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)IPATLI(I) 1316 FORMAT('ALL PATTERN LINES 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 DPPALI--') 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)MAXPAT,NUMPAT 9013 FORMAT('MAXPAT,NUMPAT = ',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)IDEFPL 9015 FORMAT('IDEFPL = ',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)IPATLI(1) 9030 FORMAT('IPATLI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IPATLI(I) 9036 FORMAT('I,IPATLI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPAPA(IHARG,NUMARG,IDEFPP,MAXPAT,IPATPA, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN (PATTERNS). C THESE ARE LOCATED IN THE VECTOR IPATPA(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFPP C --MAXPAT C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IPATPA (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-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 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFPP CHARACTER*4 IPATPA 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 IPATPA(*) 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='DPPA' ISUBN2='PA ' C NUMPAT=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 DPPAPA--') 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)MAXPAT,NUMPAT 53 FORMAT('MAXPAT,NUMPAT = ',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)IDEFPP 55 FORMAT('IDEFPP = ',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)IPATPA(1) 70 FORMAT('IPATPA(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IPATPA(I) 76 FORMAT('I,IPATPA(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=' ' 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 NUMPAT=1 IPATPA(1)=' ' GOTO1270 C 1220 CONTINUE NUMPAT=NUMARG IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT DO1225I=1,NUMPAT J=I IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPP IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPP IPATPA(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMPAT WRITE(ICOUT,1276)I,IPATPA(I) 1276 FORMAT('PATTERN ',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 NUMPAT=MAXPAT IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPP IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPP DO1315I=1,NUMPAT IPATPA(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)IPATPA(I) 1316 FORMAT('ALL PATTERNS 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 DPPAPA--') 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)MAXPAT,NUMPAT 9013 FORMAT('MAXPAT,NUMPAT = ',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)IDEFPP 9015 FORMAT('IDEFPP = ',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)IPATPA(1) 9030 FORMAT('IPATPA(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IPATPA(I) 9036 FORMAT('I,IPATPA(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPARE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, CCCCC1ICONT,IDIREC,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1ICONT,IDIREC,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A PARETO PLOT C (AN ORDERED--HIGH TO LOW) PLOT) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/8 C ORIGINAL VERSION--AUGUST 1988. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 IDIREC CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1994 CHARACTER*4 ISUBRO CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CCCCC CHARACTER*4 IH CCCCC CHARACTER*4 IH2 CCCCC CHARACTER*4 IERRO2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) C DIMENSION XIDTEM(MAXOBV) DIMENSION TEMP(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1)) EQUIVALENCE (GARBAG(IGARB4),TEMP(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='DPPA' ISUBN2='RE ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=2 C ICOLH=0 C C ********************************** C ** TREAT THE PARETO PLOT CASE ** C ********************************** C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PARE')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPARE--') 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)ICONT,IBUGG2,IBUGG3,IBUGQ 53 FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IDIREC 54 FORMAT('IDIREC = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='PAPL' IF(NUMARG.GE.1.AND. 1ICOM.EQ.'PARE'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 C ICASPL=' ' IFOUND='NO' GOTO9000 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) IFOUND='YES' GOTO190 C 190 CONTINUE C C *********************************************************** C ** STEP 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C *********************************************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,ICOLL,NLEFT 211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPPARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A PARETO 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 SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPPARE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ************************************************************ C ** STEP 5-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** IS BOTH THE HORIZONTAL AXIS VARIABLE VALUE, AND ** C ** THE CHARACTER TAG. ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** NEED NOT HAVE BEEN PREVIOUSLY ** C ** SORTED OR HAVE COMMON VALUES ADJACENT. ** C ** IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ************************************************************ C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.EQ.1)GOTO590 IF(NUMV2.EQ.2)GOTO530 GOTO510 C 510 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,511) 511 FORMAT('***** ERROR IN DPPARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,512) 512 FORMAT(' FOR A PARETO PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,518) 518 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,519) 519 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,520) 520 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,521) 521 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,522)NUMV2 522 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,523) 523 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,524)(IANS(I),I=1,IWIDTH) 524 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 530 CONTINUE IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,531)IHHOR,ICOLH,NHOR 531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(NHOR.NE.NLEFT)GOTO570 GOTO590 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPPARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A PARETO PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578) 578 FORMAT(' WHEN HAVE 2 VARAIBLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,580) 580 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' THE FIRST VARIABLE (RESPONSE VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584)IHLEFT,NLEFT 584 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE SECOND VARIABLE (HORIZ. AXIS VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586)IHHOR,NHOR 586 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH) 588 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ************************************************* C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE SECOND VARIABLE (IF EXISTENT) ** C ************************************************* C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) IF(NUMV2.LE.1)GOTO660 C IJ=MAXN*(ICOLH-1)+I IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I) C 660 CONTINUE NLOCAL=J C C ************************************************************* C ** STEP 8-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, ** C ** AND THE UPPER CONFIDENCE LINE. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='8' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C 809 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1994 MAXTAG=NLOCAL IF(NUMV2.GE.2)THEN MAXTAG=X1(1) DO820I=1,NLOCAL IF(X1(I).GT.MAXTAG)MAXTAG=X1(I) 820 CONTINUE ENDIF C CCCCC MAXTAG WAS ADDED AS AN ARGUMENT BELOW DECEMBER 1994 CCCCC ISUBRO WAS ADDED AS AN ARGUMENT BELOW DECEMBER 1994 CALL DPPAR2(Y1,X1,NLOCAL,NUMV2,MAXTAG,ICASPL,ICONT,IDIREC, CCCCC1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) 1Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PARE')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IDIREC 9014 FORMAT('IDIREC = ',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 DPPAR2(Y,X,N,NUMV2,MAXTAG,ICASPL,ICONT,IDIREC, CCCCC1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) 1Y2,X2,D2,N2,NPLOTV,ISUBRO,IBUGG3,IERROR) CCCCC MAXTAG WAS ADDED TO THE ABOVE LIST DECEMBER 1994 CCCCC ISUBRO WAS ADDED TO THE ABOVE LIST DECEMBER 1994 C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A PARETO PLOT. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/8 C ORIGINAL VERSION--AUGUST 1988. C UPDATED --APRIL 1992. NUMSET TO NUMV2 C UPDATED --DECEMBER 1994. ADD MAXTAG FOR 2-ARG C UPDATED --DECEMBER 1994. REWRITE MOST OF CODE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 IDIREC CHARACTER*4 ISUBRO CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPPA' ISUBN2='R2 ' C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1994 IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PAR2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPAR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,N,NUMV2,MAXTAG,IERROR 52 FORMAT('ICASPL,N,NUMV2,MAXTAG,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IDIREC 53 FORMAT('IDIREC = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)N,N2,NPLOTV 54 FORMAT('N,N2,NPLOTV = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) DO81I=1,N WRITE(ICOUT,82)I,Y(I),X(I) 82 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 81 CONTINUE DO85I=1,N2 WRITE(ICOUT,999) WRITE(ICOUT,86)I,Y2(I),X2(I),D2(I) 86 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 85 CONTINUE 90 CONTINUE C IF(NUMV2.EQ.1)THEN DO1112I=1,N X(I)=I 1112 CONTINUE ENDIF C IF(IDIREC.EQ.'DECR')THEN DO1120I=1,N Y(I)=(-Y(I)) 1120 CONTINUE ENDIF C CALL SORTC(Y,X,N,Y2,D2) C IF(IDIREC.EQ.'DECR')THEN DO1130I=1,N Y2(I)=(-Y2(I)) 1130 CONTINUE ENDIF C CCCCC IF(NUMV2.EQ.1)THEN DO1140I=1,N X2(I)=I 1140 CONTINUE CCCCC ENDIF C K=N DO1150I=1,N K=K+1 Y2(K)=Y2(I) X2(K)=X2(I) CCCCC THE FOLLOWING LINE WAS FIXED DECEMBER 1994 CCCCC D2(K)=N+1 D2(K)=MAXTAG+1 1150 CONTINUE C N2=K NPLOTV=3 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PAR2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPAR2--') CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE FIXED APRIL 1992 CCCCC WRITE(ICOUT,9012)ICASPL,N,NUMSET,IERROR C9012 FORMAT('ICASPL,N,NUMSET,IERROR = ',A4,2I8,2X,A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE AUGMENTED DECEMBER 1994 CCCCC WRITE(ICOUT,9012)ICASPL,N,NUMV2,IERROR C9012 FORMAT('ICASPL,N,NUMV2,IERROR = ',A4,2I8,2X,A4) WRITE(ICOUT,9012)ICASPL,N,NUMV2,MAXTAG,IERROR 9012 FORMAT('ICASPL,N,NUMV2,MAXTAG,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDIREC 9013 FORMAT('IDIREC = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N2,NPLOTV 9014 FORMAT('N2,NPLOTV = ',I8,2X,I8) CALL DPWRST('XXX','BUG ') DO9035I=1,N2 WRITE(ICOUT,9036)I,Y2(I),X2(I),D2(I) 9036 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPASP(IHARG,IARGT,ARG,NUMARG,PDEFPG,MAXPAT,PPATSP, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN SPACINGS. C THESE ARE LOCATED IN THE VECTOR PPATSP(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEFPG C --MAXPAT C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PPATSP (A FLOATING POINT VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-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 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) DIMENSION PPATSP(*) 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='DPPA' ISUBN2='SP ' C NUMPAT=0 IHOLD1='-999' HOLD1=-999.0 HOLD2=-999.0 C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPASP--') 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)MAXPAT,NUMPAT 53 FORMAT('MAXPAT,NUMPAT = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)PDEFPG 55 FORMAT('PDEFPG = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)PPATSP(1) 70 FORMAT('PPATSP(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PPATSP(I) 76 FORMAT('I,PPATSP(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=' ' IF(IHARG(2).EQ.'ALL')HOLD1=PDEFPG IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMPAT=1 PPATSP(1)=PDEFPG GOTO1270 C 1220 CONTINUE NUMPAT=NUMARG-1 IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT DO1225I=1,NUMPAT J=I+1 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFPG IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPG IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPG IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPG PPATSP(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMPAT WRITE(ICOUT,1276)I,PPATSP(I) 1276 FORMAT('PATTERN SPACING ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMPAT=MAXPAT HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFPG IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPG IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPG IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPG DO1315I=1,NUMPAT PPATSP(I)=HOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)PPATSP(I) 1316 FORMAT('ALL PATTERN SPACINGS 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 DPPASP--') 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)MAXPAT,NUMPAT 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PDEFPG 9015 FORMAT('PDEFPG = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)PPATSP(1) 9030 FORMAT('PPATSP(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PPATSP(I) 9036 FORMAT('I,PPATSP(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPASW(IHARG,NUMARG,IDEFPS,MAXPAT,IPATSW, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN SWITCHES. C THESE ARE LOCATED IN THE VECTOR IPATSW(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFPS C --MAXPAT C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IPATSW (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-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 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFPS CHARACTER*4 IPATSW 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 IPATSW(*) 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='DPPA' ISUBN2='SW ' C NUMPAT=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 DPPASW--') 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)MAXPAT,NUMPAT 53 FORMAT('MAXPAT,NUMPAT = ',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)IDEFPS 55 FORMAT('IDEFPS = ',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)IPATSW(1) 70 FORMAT('IPATSW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IPATSW(I) 76 FORMAT('I,IPATSW(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='ON' 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 NUMPAT=1 IPATSW(1)='ON' GOTO1270 C 1220 CONTINUE NUMPAT=NUMARG IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT DO1225I=1,NUMPAT J=I IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPS CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPS IPATSW(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMPAT WRITE(ICOUT,1276)I,IPATSW(I) 1276 FORMAT('PATTERN ',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 NUMPAT=MAXPAT IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFPS CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFPS DO1315I=1,NUMPAT IPATSW(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)IPATSW(I) 1316 FORMAT('ALL PATTERNS 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 DPPASW--') 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)MAXPAT,NUMPAT 9013 FORMAT('MAXPAT,NUMPAT = ',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)IDEFPS 9015 FORMAT('IDEFPS = ',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)IPATSW(1) 9030 FORMAT('IPATSW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IPATSW(I) 9036 FORMAT('I,IPATSW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPAT(IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A PATTERN. C GENERATE ELEMENTS OF A PATTERN C BY THE FORM (FOR EXAMPLE) LET Y = PATTERN 1 1 2 2 3 3 C (FOR A FULL VARIABLE OR PART OF A VARIABLE). C OUTPUT--NECESSARILY A VARIABLE. C EXAMPLE--LET Y = 1 1 2 2 3 3 (A FULL VARIABLE C --LET Y = 1 1 2 2 3 3 SUBSET 2 3 5 (A PARTIAL VAR.) C --LET Y = 1 1 2 2 3 3 FOR I = 1 2 10 (A PARTIAL VAR.) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JULY 1981. C UPDATED --OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 NEWCOL CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 ILEFT CHARACTER*4 ILEFT2 CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPPA' ISUBN2='TT ' 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 NLEFT=0 ICOLL=0 NRAWPA=0 NNUM=0 NS2=0 NS2MOD=0 C ILEFT='UNKN' ILEFT2='UNKN' C C C ******************************************************** C ** TREAT THE SUBCASE OF GENERATING A PATTERN ** C ** 1) FOR A FULL VARIABLE, OR ** C ** 2) FOR PART OF A VARIABLE. ** C ******************************************************** C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPAT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,IBUGQ 52 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' NEWCOL='NO' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=4 MAXNA=1000 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************************************** C ** STEP 3-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILEFT IS THE NAME OF THE VARIABLE * C ** ON THE LEFT. * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C ** NOTE THAT ICOLL IS THE DATA COLUMN (1 TO 12) * C ** FOR THE NAME OF THE LEFT. * C **************************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC ILEFT=IHOL(2) CCCCC ILEFT2=IHOL2(2) ILEFT=IHARG(1) ILEFT2=IHARG2(1) DO310I=1,NUMNAM I2=I IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO329 IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO380 310 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)GOTO320 GOTO330 C 320 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('***** ERROR IN DPPAT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,322) 322 FORMAT(' THE NUMBER OF VARIABLE AND/OR PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)MAXNAM 323 FORMAT(' NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ', 1I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,324) 324 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,326) 326 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,327) 327 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,328) 328 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 329 CONTINUE ILISTL=I2 GOTO330 C 330 CONTINUE NLEFT=0 ICOLL=NUMCOL+1 IF(ICOLL.GT.MAXCOL)GOTO340 GOTO390 C 340 CONTINUE WRITE(ICOUT,341) 341 FORMAT('***** ERROR IN DPPAT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,342) 342 FORMAT(' THE NUMBER OF DATA COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,343)MAXCOL 343 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,344) 344 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,345) 345 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,346) 346 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,347) 347 FORMAT(' AND THEN OVERWRITE SOME COLUMNS. EXAMPLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,348) 348 FORMAT(' IF LET X = 1 2 9 FAILED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,349) 349 FORMAT(' THEN ONE MIGHT ENTER NAME X 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,350) 350 FORMAT(' (THEREBY EQUATING THE NAME X WITH COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,351) 351 FORMAT(' FOLLOWED BY LET X = 1 2 9') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,352) 352 FORMAT(' (WHICH WILL ACTUALLY OVERWRITE COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,353) 353 FORMAT(' WITH THE NUMERIC CONSTANTS 3.14)') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 380 CONTINUE ILISTL=I2 ICOLL=IVALUE(ILISTL) NLEFT=IN(ILISTL) C 390 CONTINUE C C ************************************************* C ** STEP 4-- ** C ** EXAMINE THE RIGHT-HAND SIDE-- ** C ** DO WE HAVE A SERIES OF CONSTANTS, ** C ** OR A SERIES OF PARAMETERS, ** C ** OR A MIXTURE OF CONSTANTS AND PARAMETERS? ** C ** (ALL OF THE ABOVE ARE ALLOWED.) ** C ************************************************* C ISTEPN='4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.4)GOTO1290 1210 CONTINUE WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPPAT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' ILLEGAL SYNTAX FOR LET COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' THERE SHOULD BE AT LEAST 1') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' NUMBER OR WORD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' TO THE RIGHT OF THE WORD PATTERN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' FOR THIS TYPE OF LET COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217) 1217 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') NUMAM3=NUMARG-3 WRITE(ICOUT,1218)NUMAM3 1218 FORMAT(' NUMBER OF SUCH NUMBERS/WORDS FOUND = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1219) 1219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1220)(IANS(I),I=1,IWIDTH) 1220 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 CONTINUE C C ************************************************* C ** STEP 5-- ** C ** GENERATE NRAWPA NUMBERS ** C ** IN THE RAW PATTERN. ** C ** STORE THEM TEMPORARILY IN ** C ** THE VECTOR Y(.). ** C ************************************************* C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C K=0 NRAWPA=0 DO1310J=4,NUMARG J2=J K=K+1 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO1370 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO1370 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO1370 IF(IARGT(J).EQ.'NUMB')GOTO1311 IF(IARGT(J).EQ.'WORD')GOTO1312 GOTO1360 1311 CONTINUE Y(K)=ARG(J) GOTO1310 1312 CONTINUE IH=IHARG(J) IH2=IHARG2(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 Y(K)=VALUE(ILOC) GOTO1310 1310 CONTINUE NRAWPA=K GOTO1380 C 1360 CONTINUE WRITE(ICOUT,1361) 1361 FORMAT('***** INTERNAL ERROR IN DPPAT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1362) 1362 FORMAT(' AN ARGUMENT TYPE WHICH SHOULD BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1363) 1363 FORMAT(' EITHER A NUMBER OR A WORD, IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1364)IHARG(J2),IHARG2(J2) 1364 FORMAT(' ARGUMENT = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1365)J2 1365 FORMAT(' LOCATION IN ARGUMENT LIST = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1366)IARGT(J2) 1366 FORMAT(' ARGUMENT TYPE = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1367) 1367 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1368)(IANS(I),I=1,IWIDTH) 1368 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1370 CONTINUE NRAWPA=K-1 GOTO1380 C 1380 CONTINUE IFOUND='YES' IF(NRAWPA.GE.1)GOTO1390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('***** ERROR IN DPPAT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382) 1382 FORMAT(' ILLEGAL FORM FOR THE LET COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1383) 1383 FORMAT(' THERE ARE NO ELEMENTS IN THE PATTERN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1384) 1384 FORMAT(' THIS IS CAUSED BY EITHER THE WORD PATTERN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1385) 1385 FORMAT(' BEING THE LAST WORD ON THE COMMAND LINE, OR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1386) 1386 FORMAT(' BY THE WORDS SUBSET OR FOR IMMEDIATELY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1387) 1387 FORMAT(' FOLLOWING THE WORD PATTERN ON THE COMMAND ', 1'LINE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1388) 1388 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1389)(IANS(I),I=1,IWIDTH) 1389 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1390 CONTINUE C C *********************************************************** C ** STEP 7-- ** C ** IF CALLED FOR (THAT IS, IF IBUGA3 IS ON), ** C ** PRINT OUT THE INTERMEDIATE VARIABLE Y(.). ** C ** THIS IS USEFUL FOR DIAGNOSTIC PURPOSES ** C ** IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE. ** C *********************************************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA3.EQ.'OFF')GOTO1590 WRITE(ICOUT,1551) 1551 FORMAT('OUTPUT FROM MIDDLE OF DPPAT AFTER THE RAW PATTERN ', 1'HAS BEEN GENERATED--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1552)NRAWPA 1552 FORMAT('NRAWPA = ',I8) CALL DPWRST('XXX','BUG ') IF(NRAWPA.LE.0)GOTO1590 DO1554I=1,NRAWPA WRITE(ICOUT,1555)I,Y(I) 1555 FORMAT('I,Y(I) = ',I8,F12.5) CALL DPWRST('XXX','BUG ') 1554 CONTINUE C 1590 CONTINUE C C ***************************************** C ** STEP 8-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER) ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1670 DO1610J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO1620 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO1620 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO1630 1610 CONTINUE GOTO1680 C 1620 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1680 C 1630 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1680 C 1670 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1671) 1671 FORMAT('***** INTERNAL ERROR IN DPPAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1672) 1672 FORMAT(' AT BRANCH POINT 1671--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1673) 1673 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1674) 1674 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1675)NUMARG 1675 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1676) 1676 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1677)(IANS(I),I=1,IWIDTH) 1677 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1680 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO1690 WRITE(ICOUT,1681)NUMARG,ILOCQ,ICASEQ 1681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') C 1690 CONTINUE C C ****************************************************** C ** STEP 9-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE ** C ** (BASED ON THE QUALIFIER); ** C ** DETERMINE THE NUMBER (= NNUM) ** C ** OF NUMBERS TO BE GENERATED. ** C ** NOTE THAT THE VARIABLE NIISUB ** C ** IS THE LENGTH OF THE RESULTING ** C ** VARIABLE ISUB(.). ** C ** NOTE THAT DPFOR AUTOMATICALLY EXTENDS ** C ** THE INPUT LENGTH OF ISUB(.) IF NECESSARY. ** C ** (HENCE THE REDEFINITION OF NIISUB TO NINEW ** C ** AFTER THE CALL TO DPFOR. ** C ****************************************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO1710 IF(ICASEQ.EQ.'SUBS')GOTO1720 IF(ICASEQ.EQ.'FOR')GOTO1730 C 1710 CONTINUE CCCCC IF(NEWNAM.EQ.'NO')NIISUB=NLEFT CCCCC IF(NEWNAM.EQ.'YES')NIISUB=NRAWPA NIISUB=NRAWPA DO1715I=1,NIISUB ISUB(I)=1 1715 CONTINUE NS=NIISUB NNUM=NIISUB GOTO1750 C 1720 CONTINUE NIISUB=MAXN CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR) NNUM=NS GOTO1750 C 1730 CONTINUE IF(NEWNAM.EQ.'NO')NIISUB=NLEFT IF(NEWNAM.EQ.'YES')NIISUB=MAXN CALL DPFOR(NIISUB,NINEW,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NIISUB=NINEW NNUM=NS GOTO1750 C 1750 CONTINUE C C ****************************************************** C ** STEP 10-- ** C ** COPY THE PATTERN ** C ** FROM THE INTERMEDIATE VECTOR Y(.) ** C ** TO THE APPROPRIATE COLUMN ** C ** (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR) ** C ** IN THE INTERNAL DATAPLOT DATA TABLE. ** C ****************************************************** C ISTEPN='10' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NS2=0 NS2MOD=0 DO2100I=1,NIISUB IJ=MAXN*(ICOLL-1)+I IF(ISUB(I).EQ.0)GOTO2100 NS2=NS2+1 NS2MOD=NS2MOD+1 IF(NS2.EQ.1)IROW1=I IF(NS2MOD.GT.NRAWPA)NS2MOD=NS2MOD-NRAWPA IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2MOD) IROWN=I 2100 CONTINUE NNUM=NS2 C C ******************************************* C ** STEP 11-- ** C ** CARRY OUT THE LIST UPDATING AND ** C ** GENERATE THE INFORMATIVE PRINTING. ** C ******************************************* C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.NRAWPA)NINEW=NLEFT IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.NRAWPA)NINEW=NRAWPA IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=NIISUB IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN C IHNAME(ILISTL)=ILEFT IHNAM2(ILISTL)=ILEFT2 IUSE(ILISTL)='V' IVALUE(ILISTL)=ICOLL VALUE(ILISTL)=ICOLL IN(ILISTL)=NINEW C CCCCC IUSE(ICOLL)='V' CCCCC IVALUE(ICOLL)=ICOLL CCCCC VALUE(ICOLL)=ICOLL CCCCC IN(ICOLL)=NINEW C IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1 C DO2400J4=1,NUMNAM IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO2405 GOTO2400 2405 CONTINUE IUSE(J4)='V' IVALUE(J4)=ICOLL VALUE(J4)=ICOLL IN(J4)=NINEW 2400 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO2459 IF(IFEEDB.EQ.'OFF')GOTO2459 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2411)ILEFT,ILEFT2,NNUM 2411 FORMAT('THE NUMBER OF VALUES GENERATED FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IJ=MAXN*(ICOLL-1)+IROW1 IF(ICOLL.LE.MAXCOL)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,V(IJ),IROW1 2421 FORMAT('THE FIRST COMPUTED VALUE OF ', 1 A4,A4,' = ',E15.7,' (ROW ',I6,')') CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP1)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,PRED(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP2)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,RES(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP3)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,YPLOT(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP4)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,XPLOT(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP5)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,X2PLOT(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP6)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,TAGPLO(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ENDIF C IJ=MAXN*(ICOLL-1)+IROWN IF(ICOLL.LE.MAXCOL.AND. 1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,V(IJ),IROWN 2431 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ',A4,A4, 1' = ',E15.7,' (ROW ',I6,')') IF(ICOLL.LE.MAXCOL.AND. 1NNUM.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP1.AND. 1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,PRED(IROWN),IROWN IF(ICOLL.EQ.MAXCP1.AND. 1NNUM.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP2.AND. 1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,RES(IROWN),IROWN IF(ICOLL.EQ.MAXCP2.AND. 1NNUM.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP3.AND. 1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,YPLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP3.AND. 1NNUM.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP4.AND. 1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,XPLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP4.AND. 1NNUM.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP5.AND. 1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP5.AND. 1NNUM.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP6.AND. 1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN IF(ICOLL.EQ.MAXCP6.AND. 1NNUM.NE.1)CALL DPWRST('XXX','BUG ') IF(NNUM.NE.1)GOTO2449 WRITE(ICOUT,2441) 2441 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2442) 2442 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.') CALL DPWRST('XXX','BUG ') 2449 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2451)ILEFT,ILEFT2,ICOLL 2451 FORMAT('THE CURRENT COLUMN FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2453)ILEFT,ILEFT2,NINEW 2453 FORMAT('THE CURRENT LENGTH OF ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 2459 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPAT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGA3,IBUGQ 9013 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)MAXN,NRAWPA,NS2,NS2MOD,NNUM 9015 FORMAT('MAXN,NRAWPA,NS2,NS2MOD,NNUM = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NS,NIISUB,NNUM 9016 FORMAT('NS,NIISUB,NNUM = ',I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)NLEFT,NRAWPA,NIISUB,IROW1,IROWN,NINEW 9018 FORMAT('NLEFT,NRAWPA,NIISUB,IROW1,IROWN,NINEW = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)ILEFT,ILEFT2,NEWNAM,ICOLL,NINEW 9019 FORMAT('ILEFT,ILEFT2,NEWNAM,ICOLL,NINEW = ',A4,A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPATH(IHARG,IARGT,ARG,NUMARG,PDEFPT,MAXPAT,PPATTH, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN THICKNESSES. C THESE ARE LOCATED IN THE VECTOR PPATTH(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEFPT C --MAXPAT C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PPATTH (A FLOATING POINT VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-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 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) DIMENSION PPATTH(*) 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='DPPA' ISUBN2='TH ' C IFOUND='NO' IERROR='NO' C NUMPAT=0 IHOLD1='-999' HOLD1=-999.0 HOLD2=-999.0 C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPATH--') 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)MAXPAT,NUMPAT 53 FORMAT('MAXPAT,NUMPAT = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)PDEFPT 55 FORMAT('PDEFPT = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)PPATTH(1) 70 FORMAT('PPATTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PPATTH(I) 76 FORMAT('I,PPATTH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=' ' IF(IHARG(2).EQ.'ALL')HOLD1=PDEFPT IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMPAT=1 PPATTH(1)=PDEFPT GOTO1270 C 1220 CONTINUE NUMPAT=NUMARG-1 IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT DO1225I=1,NUMPAT J=I+1 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFPT IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPT PPATTH(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMPAT WRITE(ICOUT,1276)I,PPATTH(I) 1276 FORMAT('PATTERN THICKNESS ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMPAT=MAXPAT HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFPT IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPT DO1315I=1,NUMPAT PPATTH(I)=HOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)PPATTH(I) 1316 FORMAT('ALL PATTERN THICKNESSES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPATH--') 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)MAXPAT,NUMPAT 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PDEFPT 9015 FORMAT('PDEFPT = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)PPATTH(1) 9030 FORMAT('PPATTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PPATTH(I) 9036 FORMAT('I,PPATTH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPATT(IHARG,NUMARG, 1IDEFPA, 1ITEXPA, 1IBUGD2,ISUBRO,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN FOR THE LINES C IN TEXT AND FIGURES. C THE PATTERN WILL BE PLACED C IN THE CHARACTER VARIABLE ITEXPA. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFPA C OUTPUT ARGUMENTS--ITEXPA C --IBUGD2 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--DECEMBER 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFPA CHARACTER*4 ITEXPA CHARACTER*4 IBUGD2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPATT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IDEFPA 53 FORMAT('IDEFPA = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I) 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C IF(NUMARG.EQ.0)GOTO1140 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1140 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1160 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160 GOTO1170 C 1140 CONTINUE ITEXPA=' ' GOTO1180 C 1150 CONTINUE ITEXPA='SOLI' GOTO1180 C 1160 CONTINUE ITEXPA=IDEFPA GOTO1180 C 1170 CONTINUE ITEXPA=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE PATTERN (FOR LINES IN TEXT AND FIGURES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)ITEXPA 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPATT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDEFPA,ITEXPA 9013 FORMAT('IDEFPA,ITEXPA = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPAUS(IBUGS2,IFOUND,IERROR) C C PURPOSE--READ A LINE FROM THE TERMINAL C (THIS HAS THE NET EFFECT OF CAUSING C A PROGRAM TO PAUSE UNTIL THIS JUNK LINE IS READ). C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C C-----NON-COMMON VARIABLES------------------------------------------------------ C CHARACTER*4 IBUGS2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='YES' IERROR='NO' C IF(IBUGS2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE END OF DPPAUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGS2,IFOUND,IERROR 52 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************************** C ** STEP 1-- ** C ** READ IN A JUNK LINE FROM THE TERMINAL ** C ********************************************** C READ(IRD,1105)IJUNK 1105 FORMAT(A4) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPAUS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPAWI(IHARG,IARGT,ARG,NUMARG,PDEFPW,MAXPAT,PPATWI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN WIDTHS. C THESE ARE LOCATED IN THE VECTOR PPATWI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEFPW C --MAXPAT C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PPATWI (A FLOATING POINT VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-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 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) DIMENSION PPATWI(*) 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='DPPA' ISUBN2='WI ' C NUMPAT=0 IHOLD1='-999' HOLD1=-999.0 HOLD2=-999.0 C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPAWI--') 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)MAXPAT,NUMPAT 53 FORMAT('MAXPAT,NUMPAT = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)PDEFPW 55 FORMAT('PDEFPW = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)PPATWI(1) 70 FORMAT('PPATWI(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PPATWI(I) 76 FORMAT('I,PPATWI(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=' ' IF(IHARG(2).EQ.'ALL')HOLD1=PDEFPW IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMPAT=1 PPATWI(1)=PDEFPW GOTO1270 C 1220 CONTINUE NUMPAT=NUMARG-1 IF(NUMPAT.GT.MAXPAT)NUMPAT=MAXPAT DO1225I=1,NUMPAT J=I+1 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFPW IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPW IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPW IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPW PPATWI(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMPAT WRITE(ICOUT,1276)I,PPATWI(I) 1276 FORMAT('PATTERN WIDTH ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMPAT=MAXPAT HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFPW IF(IHOLD1.EQ.'OFF')HOLD2=PDEFPW IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFPW IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFPW DO1315I=1,NUMPAT PPATWI(I)=HOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)PPATWI(I) 1316 FORMAT('ALL PATTERN WIDTHS 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 DPPAWI--') 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)MAXPAT,NUMPAT 9013 FORMAT('MAXPAT,NUMPAT = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PDEFPW 9015 FORMAT('PDEFPW = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)PPATWI(1) 9030 FORMAT('PPATWI(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PPATWI(I) 9036 FORMAT('I,PPATWI(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPCPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE A PARALLEL COORDINATES PLOT-- C A PARALLEL COORDINATES PLOT DOES THE FOLLOWING: C 1) STANDARDIZE ALL VARIABLES C 2) FOR P VARIABLES AND N POINTS, LET X(I,J) = THE C STANDARDIZED VALUE OF OBSERVATION (ROW) I AND C VARIABLE (COLUMN) J. C 3) GENERATE THE FOLLOWING PLOT COORDINATES: C (X(I-1,K-1), K-1) - (X(I,K),K) FOR I = 2, ..., N C FOR K = 2, ..., P C WRITTEN BY--ALAN HECKERT C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C REFERENCE--ED WEGMAN, xxxxx C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003/3 C ORIGINAL VERSION--MARCH 2003. C UPDATED --MAY 2003. GROUP PARALLEL COORDINATES C PLOT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IVARN1 CHARACTER*4 IVARN2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C C MAXPCC IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE C PARALLEL COORDINATES PLOT C PARAMETER(MAXPCC=30) C DIMENSION IVARN1(MAXPCC) DIMENSION IVARN2(MAXPCC) DIMENSION ILIS(MAXPCC) DIMENSION Z(MAXOBV,MAXPCC) DIMENSION TEMP(MAXOBV) DIMENSION XIDTEM(MAXOBV) INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),Z(1,1)) EQUIVALENCE (G2RBAG(IGAR51),TEMP(1)) EQUIVALENCE (G2RBAG(IGAR52),XIDTEM(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOST.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='DPPC' ISUBN2='PL ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=1 C ICOLH=0 C C ************************************************ C ** TREAT THE PARALLEL COORDINATES PLOT CASE ** C ************************************************ C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PCPL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPCPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO 52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='PCPL' C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COOR'.AND.IHARG(2).EQ.'PLOT')THEN ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) IFOUND='YES' ICASPL='PCPL' ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'PARA'.AND. 1 IHARG(2).EQ.'COOR'.AND.IHARG(3).EQ.'PLOT')THEN ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) IFOUND='YES' ICASPL='PCPG' ELSE IFOUND='NO' GOTO9000 ENDIF C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 IF(ICASPL.EQ.'PCPG')MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 11-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1180 DO1100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO1110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO1110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO1120 1100 CONTINUE GOTO1180 1110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1190 1120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1190 C 1180 CONTINUE GOTO1190 C 1190 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PCPL')GOTO1195 WRITE(ICOUT,1191)NUMARG,ILOCQ,ICASEQ 1191 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 1195 CONTINUE C C ************************************************** C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ** TO BE INCLUDED AS PLOT COMPONENTS ** C ** IF THE TO FEATURE IS USED IN THE ** C ** ARGUMENT LIST, TRANSLATE THE TO TO ** C ** EXPLICIT VARIABLE NAMES ** C ************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=1 JMAX=ILOCQ-1 CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXPCC, 1IHNAME,IHNAM2,IUSE,NUMNAM, 1IVARN1,IVARN2,NUMVAR,IBUGG2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C 1290 CONTINUE C C *************************************** C ** STEP 13-- ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE VARIABLES. ** C ** ALSO CHECK TO ASSURE THAT EACH ** C ** OF THE VARIABLES HAS AT LEAST ** C ** 2 OBSERVATIONS. ** C *************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=0 DO1300I=1,NUMVAR C IHRIGH=IVARN1(I) IHRIG2=IVARN2(I) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C NRIGHT=IN(ILOCV) IF(I.EQ.1)THEN NTEMP=NRIGHT ELSE IF(NRIGHT.NE.NTEMP)IFLAG=1 ENDIF ILIS(I)=ILOCV IF(NRIGHT.LT.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN DPPCPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1321) 1321 FORMAT(' PARALLEL COORDINATES PLOT WAS TO HAVE BEEN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326)MINN2 1326 FORMAT(' FORMED MUST BE ',I8,' OR LARGER; SUCH WAS ', 1 ' NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1328) 1328 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1329)(IANS(J),J=1,MIN(80,IWIDTH)) 1329 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C 1300 CONTINUE C C C ****************************************************** C ** STEP 1.4-- ** C ** CHECK THAT VARIABLES HAVE THE SAME NUMBER OF ** C ** ELEMENTS. ** C ****************************************************** C 1400 CONTINUE ISTEPN='1.4' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFLAG.NE.0)THEN WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPPCPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) 1413 FORMAT(' THE NUMBER OF OBSERVATIONS IN ALL VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415) 1415 FORMAT(' MUST BE THE SAME. SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') DO1417I=1,NUMVAR I2=ILIS(I) WRITE(ICOUT,1416)IVARN1(I2),IVARN2(I2),IN(I2) 1416 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1 ' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') 1417 CONTINUE WRITE(ICOUT,1420) 1420 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1421)(IANS(I),I=1,MIN(80,IWIDTH)) 1421 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ************************************************* C ** STEP 21-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FOR EACH OF THE RESPONSE VARIABLES ** C ** EXTRACT THE DATA SUBSET ** C ** (USUALLY ONLY 1 OBSERVATION) ** C ** AND ALSO EXTRACT THE ** C ** MIN AND MAX FOR THE FULL VARIABLE ** C ************************************************* C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO2110 IF(ICASEQ.EQ.'SUBS')GOTO2120 IF(ICASEQ.EQ.'FOR')GOTO2130 C 2110 CONTINUE DO2115I=1,NRIGHT ISUB(I)=1 2115 CONTINUE NQ=NRIGHT GOTO2190 C 2120 CONTINUE NIOLD=NRIGHT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO2190 C 2130 CONTINUE NIOLD=NRIGHT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO2190 C 2190 CONTINUE C C ************************************************* C ** STEP 22-- ** C ** FOR EACH OF THE RESPONSE VARIABLES, ** C ** EXTRACT THE DATA SUBSET ** C ** (FREQUENTLY ONLY 1 OBSERVATION) ** C ** AND ALSO EXTRACT THE ** C ** MIN AND MAX FOR THE FULL VARIABLE ** C ************************************************* C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2200K=1,NUMVAR IHRIGH=IVARN1(K) IHRIG2=IVARN2(K) C DO2210I=1,NUMNAM I2=I IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I).AND. 1 IUSE(I).EQ.'V')GOTO2219 2210 CONTINUE C WRITE(ICOUT,2211) 2211 FORMAT('***** INTERNAL ERROR IN DPPCPL AT POINT 2210--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212)IHRIGH,IHRIG2 2212 FORMAT(' THE VARIABLE ',A4,A4,'WAS NOT FOUND IN THE ', 1 'INTERNAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' NAME LIST ALTHOUGH IT WAS FOUND EARLIER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215) 2215 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2216)(IANS(J),J=1,MIN(80,IWIDTH)) 2216 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2219 CONTINUE C ILISTR=I2 ICOLR=IVALUE(ILISTR) NRIGHT=IN(ILISTR) C J=0 IMAX=NRIGHT IF(NQ.LT.NRIGHT)IMAX=NQ IF(ICASPL.EQ.'PCPG'.AND.K.EQ.NUMVAR)THEN DO2230I=1,IMAX IF(ISUB(I).EQ.0)GOTO2230 J=J+1 IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)XIDTEM(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)XIDTEM(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)XIDTEM(J)=RES(I) IF(ICOLR.EQ.MAXCP3)XIDTEM(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)XIDTEM(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)XIDTEM(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)XIDTEM(J)=TAGPLO(I) 2230 CONTINUE ELSE DO2240I=1,IMAX IF(ISUB(I).EQ.0)GOTO2240 J=J+1 IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)Z(J,K)=V(IJ) IF(ICOLR.EQ.MAXCP1)Z(J,K)=PRED(I) IF(ICOLR.EQ.MAXCP2)Z(J,K)=RES(I) IF(ICOLR.EQ.MAXCP3)Z(J,K)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)Z(J,K)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)Z(J,K)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)Z(J,K)=TAGPLO(I) 2240 CONTINUE ENDIF NLOCAL=J NSUB=NLOCAL C 2200 CONTINUE NZ=NUMVAR IF(ICASPL.EQ.'PCPG')NZ=NZ-1 C C ******************************************************* C ** STEP 31-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE VECTOR D(.) SO THAT EACH ANDREW'S ** C ** CURVE HAS ITS OWNS TAG NUMBER. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ******************************************************* C ISTEPN='8' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PCPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPPCP2(Z,NZ,XIDTEM,TEMP,DFILL,ICASPL,IPCCST, 1NLOCAL,MAXOBV,MAXPCC,MAXPOP, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PCPL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPCPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO 9012 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NSUB 9021 FORMAT('NSUB = ',I8) CALL DPWRST('XXX','BUG ') IF(NSUB.LE.0)GOTO9024 DO9022I=1,NSUB WRITE(ICOUT,9023)I,(Z(I,K),K=1,NUMVAR) 9023 FORMAT('I,Z(I,K) = ',I8,20E15.7) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9024 CONTINUE WRITE(ICOUT,9041)NZ 9041 FORMAT('NZ = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)NPLOTP 9051 FORMAT('NPLOTP = ',I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9054 DO9052I=1,NPLOTP WRITE(ICOUT,9053)I,Y(I),X(I),D(I) 9053 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9052 CONTINUE 9054 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPCP2(Z,NZ,XIDTEM,TEMP,DFILL,ICASPL,IPCCST, 1NOBS,MAXOBV,MAXPCC,MAXPOP, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C A ANDREWS PLOT C (USEFUL FOR MULTIVARIATE ANALYSIS). C WRITTEN BY--ALAN HECKERT C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003/3 C ORIGINAL VERSION--MARCH 2003. C MAY --MAY 2003. SUPPORT FOR "GROUP" CASE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IPCCST CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Z(MAXOBV,MAXPCC) C DIMENSION XIDTEM(*) DIMENSION TEMP(*) DIMENSION DFILL(*) C DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C EXTERNAL RANGE 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='DPPC' ISUBN2='P2 ' C IERROR='NO' C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(NOBS.LT.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN PARALLEL COORDINATES PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)NZ 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCP2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** AT THE BEGINNING OF DPPCP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ICASPL,NZ,NOBS,NPLOTV 72 FORMAT('ICASPL,NZ,NOBS,NPLOTV = ',A4,2X,3I8) CALL DPWRST('XXX','BUG ') IF(NZ.GT.0)THEN DO81I=1,NZ WRITE(ICOUT,82)I,(Z(I,K),K=1,NZ) 82 FORMAT('I,Z(I,K) = ',I8,20E12.5) CALL DPWRST('XXX','BUG ') 81 CONTINUE ENDIF ENDIF C C **************************************** C ** STEP 11-- ** C ** DETERMINE PLOT COORDINATES ** C **************************************** C IWRITE='OFF' C IF(ICASPL.EQ.'PCPG')THEN CALL CODE(XIDTEM,NOBS,IWRITE,TEMP,IBUGG3,IERROR) DO110I=1,NOBS XIDTEM(I)=TEMP(I) 110 CONTINUE ENDIF C DO200J=1,NZ IF(IPCCST.EQ.'ZSCO')THEN DO210I=1,NOBS TEMP(I)=Z(I,J) 210 CONTINUE CALL MEAN(TEMP,NOBS,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(TEMP,NOBS,IWRITE,XSD,IBUGG3,IERROR) DO220I=1,NOBS Z(I,J)=0.0 IF(XSD.GT.0.0)Z(I,J)=(TEMP(I)-XMEAN)/XSD 220 CONTINUE ELSEIF(IPCCST.EQ.'USCO')THEN DO310I=1,NOBS TEMP(I)=Z(I,J) 310 CONTINUE CALL MINIM(TEMP,NOBS,IWRITE,XMIN,IBUGG3,IERROR) CALL RANGE(TEMP,NOBS,IWRITE,XRANGE,IBUGG3,IERROR) DO320I=1,NOBS Z(I,J)=0.0 IF(XRANGE.GT.0.0)Z(I,J)=(TEMP(I)-XMIN)/XRANGE 320 CONTINUE ENDIF 200 CONTINUE C ICOUNT=0 DO600ICASE=1,NOBS C IF(ICOUNT.GT.MAXPOP-2)THEN WRITE(ICOUT,601) 601 FORMAT('****** ERROR IN PARALLEL COORDINATES PLOT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,602) 602 FORMAT(' MAXIMUM NUMBER OF PLOT POINTS EXCEEDED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C DO700J=2,NZ XCOOR1=Z(ICASE,J-1) XCOOR2=Z(ICASE,J) YCOOR1=REAL(J-1) - 1.0 YCOOR2=YCOOR1+1.0 ICOUNT=ICOUNT+1 C X2(ICOUNT)=XCOOR1 Y2(ICOUNT)=YCOOR1 D2(ICOUNT)=REAL(ICASE) DFILL(ICOUNT)=XIDTEM(ICASE) C ICOUNT=ICOUNT+1 X2(ICOUNT)=XCOOR2 Y2(ICOUNT)=YCOOR2 D2(ICOUNT)=REAL(ICASE) DFILL(ICOUNT)=XIDTEM(ICASE) 700 CONTINUE 600 CONTINUE C N2=ICOUNT NPLOTV=2 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCP2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPCP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,NZ,N2,IERROR 9012 FORMAT('ICASPL,NZ,N2,IERROR = ',A4,2I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)N2,NPLOTV 9031 FORMAT('N2,NPLOTV = ',2I8) CALL DPWRST('XXX','BUG ') DO9035I=1,N2 WRITE(ICOUT,9036)I,Y2(I),X2(I),D2(I) 9036 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9035 CONTINUE ENDIF C RETURN END SUBROUTINE DPPCTY(IHARG,NUMARG, 1IDEFPT, 1IPCMTY, 1IBUGS2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PRINCIPLE COMPONENT TYPE C CAN BE: C DATA COVARIANCE (DACV) C DATA CORRELATION (DACR) C COVARIANCE COVARIANCE (CVCV) C COVARIANCE CORRELATION (CVCR) C CORRELATION COVARIANCE (CRCV) C CORRELATION CORRELATION (CRCR) C THIS SWITCH CONTROLS HOW THE PRINCIPLE COMPONENTS ARE C COMPUTED. C C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFPT (A CHARACTER VARIABLE) C --IBUGS2 (A CHARACTER VARIABLE) C OUTPUT ARGUMENTS--IPCMTY (A CHARACTER VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--93/7 C ORIGINAL VERSION--JULY 1993. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFPT CHARACTER*4 IPCMTY CHARACTER*4 IBUGS2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGS2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPCTY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IDEFPT 53 FORMAT('IDEFPT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I) 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.2)GOTO1150 IF(NUMARG.EQ.3)GOTO1120 IF(NUMARG.EQ.4)GOTO1110 IF(NUMARG.GT.4)GOTO9000 C 1110 CONTINUE IF(IHARG(3).EQ.'DATA'.AND.IHARG(4).EQ.'COVA')THEN IHOLD='DACV' ELSEIF(IHARG(3).EQ.'DATA'.AND.IHARG(4).EQ.'CORR')THEN IHOLD='DACR' ELSEIF(IHARG(3).EQ.'CORR'.AND.IHARG(4).EQ.'CORR')THEN IHOLD='CRCR' ELSEIF(IHARG(3).EQ.'CORR'.AND.IHARG(4).EQ.'COVA')THEN IHOLD='CRCV' ELSEIF(IHARG(3).EQ.'COVA'.AND.IHARG(4).EQ.'COVA')THEN IHOLD='CVCV' ELSEIF(IHARG(3).EQ.'COVA'.AND.IHARG(4).EQ.'CORR')THEN IHOLD='CVCR' ELSE IERROR='YES' IFOUND='YES' WRITE(ICOUT,1111)IHARG(3),IHARG(4) 1111 FORMAT('THE PRINCIPLE COMPONENT TYPE ',A4,A4, 1 ' IS NOT RECOGNIZED') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF GOTO1180 C 1120 CONTINUE IF(IHARG(2).EQ.'AUTO')GOTO1150 IF(IHARG(2).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD=IDEFPT GOTO1180 C 1160 CONTINUE IHOLD=IHARG(3) IF(IHOLD.EQ.'DACV')GOTO1180 IF(IHOLD.EQ.'DACR')GOTO1180 IF(IHOLD.EQ.'CRCR')GOTO1180 IF(IHOLD.EQ.'CRCV')GOTO1180 IF(IHOLD.EQ.'CVCV')GOTO1180 IF(IHOLD.EQ.'CVCR')GOTO1180 GOTO1170 C 1170 CONTINUE IERROR='YES' IFOUND='YES' WRITE(ICOUT,1171)IHOLD 1171 FORMAT('THE PRINCIPLE COMPONENT TYPE SWITCH ',A4, 1' IS NOT RECOGNIZED') CALL DPWRST('XXX','BUG ') GOTO9000 C 1180 CONTINUE IFOUND='YES' IPCMTY=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IPCMTY 1181 FORMAT( 1'THE PRINCIPLE COMPONENT TYPE SWITCH HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C 9000 CONTINUE IF(IBUGS2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPCTY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDEFPT,IPCMTY 9013 FORMAT('IDEFPT,IPCMTY = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPEBA(IHARG,IARGT,ARG,NUMARG, 1DEPBA,APEDBA, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE BASE C FOR THE 3-D PEDESTAL. C THE BASE FOR THE PEDESTAL WILL BE PLACED C IN THE FLOATING POINT VARIABLE APEDBA. C THE BASE FOR THE PEDESTAL WILL BE C IN UNITS OF THE Z AXIS VARIABLE. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --DEPBA C OUTPUT ARGUMENTS--APEDBA 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 PEDESTAL 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 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.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 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPPEBA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL SYNTAX FOR THE PEDESTAL BASE ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER SYNTAX--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE THE Z AXIS DATA RANGES FROM ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' 500 TO 2000 ,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' AND SUPPOSE THE ANALYST WISHES THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' PLOT PEDESTAL TO HAVE A BASE AT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) 1129 FORMAT(' Z = 100; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' THEN THE PROPER SYNTAX IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' PEDESTAL BASE 100 ') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE APEDBA=DEPBA GOTO1180 C 1160 CONTINUE APEDBA=ARG(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)APEDBA 1181 FORMAT('THE (3-D) PEDESTAL BASE ', 1'HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPECL(IHARG,NUMARG,IDEPCO,IPEDCO,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE 3-D PEDESTAL. C THE COLOR FOR THE PEDESTAL WILL BE PLACED C IN THE CHARACTER VARIABLE IPEDCO. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEPCO C OUTPUT ARGUMENTS--IPEDCO 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 PEDESTAL 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--82/7 C ORIGINAL VERSION--SEPTEMBER 1980. C UPDATED --MAY 1982. C UPDATED --SEPTEMBER 1988. (WITH GENERAL 3-D UPDATE) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEPCO CHARACTER*4 IPEDCO 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 IPEDCO=IDEPCO GOTO1180 C 1160 CONTINUE IPEDCO=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)IPEDCO 1181 FORMAT('THE (3-D) PEDESTAL COLOR ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPED(IHARG,NUMARG,IPEDSW,IFOUND,IERROR) C C PURPOSE--DEFINE THE 3-D PEDESTAL SWITCH IPEDSW. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IPEDSW ('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 PEDESTAL 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--82/7 C ORIGINAL VERSION--SEPTEMBER 1980. C UPDATED --FEBRUARY 1982. C UPDATED --MAY 1982. C UPDATED --SEPTEMBER 1988. (WITH GENERAL 3-D UPDATE) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IPEDSW 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 IPEDSW='ON' GOTO1180 C 1160 CONTINUE IPEDSW='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)IPEDSW 1181 FORMAT('THE (3-D) PEDESTAL SWITCH ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPEGC(IHARG,NUMARG,IDEPGC,IPEDGC,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE 3-D PEDESTAL GRID. C THE COLOR FOR THE PEDESTAL GRID WILL BE PLACED C IN THE CHARACTER VARIABLE IPEDGC. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEPGC C OUTPUT ARGUMENTS--IPEDGC 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 PEDESTAL 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 IDEPGC CHARACTER*4 IPEDGC 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 IPEDGC=IDEPGC GOTO1180 C 1160 CONTINUE IPEDGC=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)IPEDGC 1181 FORMAT('THE (3-D) PEDESTAL GRID COLOR ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPEGP(IHARG,NUMARG,IDEPGP,IPEDGP,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN FOR THE 3-D PEDESTAL GRID. C THE PATTERN FOR THE PEDESTAL GRID WILL BE PLACED C IN THE CHARACTER VARIABLE IPEDGP. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEPGP C OUTPUT ARGUMENTS--IPEDGP 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 PEDESTAL 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 IDEPGP CHARACTER*4 IPEDGP 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 IPEDGP='SOLI' GOTO1180 C 1160 CONTINUE IPEDGP='BLAN' GOTO1180 C 1170 CONTINUE IPEDGP=IDEPGP GOTO1180 C 1175 CONTINUE IPEDGP=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)IPEDGP 1181 FORMAT('THE (3-D) PEDESTAL GRID PATTERN ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPEGR(IHARG,NUMARG,IDEPGR,IPEDGR,IFOUND,IERROR) C C PURPOSE--DEFINE THE 3-D PEDESTAL GRID SWITCH IPEDGR. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEPGR C OUTPUT ARGUMENTS--IPEDGR ('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 PEDESTAL 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/11 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEPGR CHARACTER*4 IPEDGR 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 IPEDGR='ON' GOTO1180 C 1160 CONTINUE IPEDGR='OFF' GOTO1180 C 1170 CONTINUE IPEDGR=IDEPGR 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)IPEDGR 1181 FORMAT('THE (3-D) PEDESTAL GRID SWITCH ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPEI2(Y1,Y2,N,ICASPL,MAXN, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C 1) AUTOPERIODOGRAM C 2) CO-PERIODOGRAM; C 3) QUADRATURE PERIODOGRAM; C 4) CROSS-PERIODOGRAM (CO-PERIODOGRAMM AND CROSS-PERIODOGRAMM); C NOTE--AN AUTOPERIODOGRAM, C IN ORDER THAT THE RESULTS OF THE TIME SERIES ANALYSIS C BE VALID AND PROPERLY INTERPRETED, THE INPUT DATA C IN X SHOULD BE EQUI-SPACED IN TIME C (OR WHATEVER VARIABLE CORRESPONDS TO TIME). C C THE HORIZONTAL AXIS OF THE PERIODOGRAM PRODUCED C BY THIS SUBROUTINE IS FREQUENCY. C THIS FREQUENCY IS MEASURED IN UNITS OF C CYCLES PER 'DATA POINT' OR, MORE PRECISELY, IN C CYCLES PER UNIT TIME WHERE C 'UNIT TIME' IS DEFINED AS THE C ELAPSED TIME BETWEEN ADJACENT OBSERVATIONS. C THE RANGE OF THE FREQUENCY AXIS IS 0.0 TO 0.5. C C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C FOR THE FIRST VARIABLE. C --Y2 = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS. C FOR THE SECOND VARIABLE. C N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C PRINTING--YES. C RESTRICTIONS--THE SAMPLE SIZE N MUST BE C SMALLER THAN OR EQUAL TO 1000. C --THE SAMPLE SIZE N MUST BE GREATER C THAN OR EQUAL TO 3. C OTHER DATAPAC SUBROUTINES NEEDED--PLOTC0, PLOTSP, AND CHSPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE 'FAST FOURIER TRANSFORM' IS NOT USED C IN THIS VERSION OF TIME, BUT WILL BE C IMPLEMENTED IN A FUTURE VERSION. C --THE USUAL MAXIMUM NUMBER OF LAGS C FOR WHICH THE AUTOCORRELATION IS C COMPUTED IS N/4 WHERE N IS C THE SAMPLE SIZE (LENGTH OF THE C DATA RECORD IN THE VECTOR X). C THIS RULE IS OVERRIDDEN IN C LARGE DATA SETS AND IS REPLACED C BY THE RULE THAT THE MAXIMUM C NUMBER OF LAGS = 500 C (WHICH CORRESPONDS TO AN C AUTOCORRELATION PLOT COVERING C 5 COMPUTER PAGES). C IF MORE LAGS ARE DESIRED, C CHANGE THE VALUE OF THE C VARIABLE MAXLAG C WITHIN THIS SUBROUTINE C FROM 500 TO WHATEVER DESIRED, C AND ALSO CHANGE THE DIMENSION OF C THE VECTOR R FROM ITS PRESENT 500 TO HOWEVER C MANY LAGS ARE DESIRED. C --IF THE INPUT OBSERVATIONS IN X ARE CONSIDERED C TO HAVE BEEN COLLECTED 1 SECOND APART IN TIME, C THEN THE FREQUENCY AXIS OF THE RESULTING C PERIODOGRAM WOULD BE IN UNITS OF HERTZ C (= CYCLES PER SECOND). C --THE FREQUENCY OF 0.0 CORRESPONDS TO A CYCLE C IN THE DATA OF INFINITE (= 1/(0.0)) C LENGTH OR PERIOD. C THE FREQUENCY OF 0.5 CORRESPONDS TO A CYCLE C IN THE DATA OF LENGTH = 1/(0.5) = 2 DATA POINTS. C --ANY EQUI-SPACED TIME SERIES ANALYSIS IS C INTRINSICALLY LIMITED TO DETECTING FREQUENCIES C NO LARGER THAN 0.5 CYCLES PER DATA POINT; C THIS CORRESPONDS TO THE FACT THAT THE C SMALLEST DETECTABLE CYCLE IN THE DATA C IS 2 DATA POINTS PER CYCLE. C REFERENCES--JENKINS AND WATTS, ESPECIALLY PAGE 290. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--AUGUST 1981. C UPDATED --NOVEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265359/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPPE' ISUBN2='I2 ' C IERROR='NO' C Y2BAR=0.0 C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPPEI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(N.GE.2)GOTO49 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN DPPEI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47) 47 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48) 48 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 49 CONTINUE C HOLD=Y1(1) DO60I=1,N IF(Y1(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPPEI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL ELEMENTS IN Y1 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO80 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPPEI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASPL,MAXN 71 FORMAT('N,ICASPL,MAXN = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y1(I),Y2(I) 74 FORMAT('I, Y1(I), Y2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE 80 CONTINUE C C ******************************* C ** STEP 1-- ** C ** COMPUTE THE SAMPLE MEAN ** C ******************************* C AN=N SUM=0.0 DO100I=1,N SUM=SUM+Y1(I) 100 CONTINUE Y1BAR=SUM/AN C IF(ICASPL.EQ.'AUPE')GOTO190 C SUM=0.0 DO110I=1,N SUM=SUM+Y2(I) 110 CONTINUE Y2BAR=SUM/AN C 190 CONTINUE C C ************************************* C ** STEP 2-- ** C ** COMPUTE THE SAMPLE VARIANCE ** C ** AND SUM OF SQUARED DEVIATIONS ** C ************************************* C SUM=0.0 DO200I=1,N SUM=SUM+(Y1(I)-Y1BAR)*(Y1(I)-Y1BAR) 200 CONTINUE SSQY1=SUM VARBY1=SSQY1/AN VARY1=SSQY1/(AN-1.0) IF(VARY1.LE.0.0)SDY1=0.0 IF(VARY1.GT.0.0)SDY1=SQRT(VARY1) C IF(ICASPL.EQ.'AUPE')GOTO290 C SUM=0.0 DO210I=1,N SUM=SUM+(Y2(I)-Y2BAR)*(Y2(I)-Y2BAR) 210 CONTINUE SSQY2=SUM VARBY2=SSQY2/AN VARY2=SSQY2/(AN-1.0) IF(VARY2.LE.0.0)SDY2=0.0 IF(VARY2.GT.0.0)SDY2=SQRT(VARY2) C SUM=0.0 DO220I=1,N SUM=SUM+(Y1(I)-Y1BAR)*(Y2(I)-Y2BAR) 220 CONTINUE SSQ12=SUM COVB12=SSQ12/AN COVB21=COVB12 C 290 CONTINUE C C C C ************************************** C ** STEP 4-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ** AND DETERMINE PLOT COORDINATES ** C ************************************** C C **************************************************************** C ** STEP 4.1-- C ** COMPUTE AUTOPERIODOGRAM FOR Y1 C ** REFERENCE--JUNKINS AND WATTS--PAGES 21 AND 22 (2.1.12) C **************************************************************** C 1000 CONTINUE IF(ICASPL.EQ.'AUPE')GOTO1100 GOTO1900 C 1100 CONTINUE C NHALF=N/2 NHALFP=NHALF+1 IMAX=NHALFP IF(NHALFP.GT.MAXN)IMAX=MAXN IEVODD=N-2*(N/2) DEL=(AN+1.0)/2.0 IF(IEVODD.EQ.0)DEL=(AN+2.0)/2.0 C J=0 CCCCC DO1110IP1=1,IMAX DO1110IP1=2,IMAX J=J+1 I=IP1-1 AI=I FREQI=AI/AN SUMA=0.0 SUMB=0.0 C DO1120K=1,N AK=K OMEGA=2.0*PI*(AI/AN) SUMA=SUMA+Y1(K)*COS(OMEGA*(AK-DEL)) SUMB=SUMB+Y1(K)*SIN(OMEGA*(AK-DEL)) Z=AK-DEL 1120 CONTINUE AICOEF=SUMA/AN BICOEF=SUMB/AN RSQ=AICOEF*AICOEF+BICOEF*BICOEF POWERI=2.0*RSQ IF(I.EQ.0)POWERI=POWERI/2.0 IF(I.EQ.NHALF.AND.IEVODD.EQ.0)POWERI=POWERI/2.0 IF(IBUGG3.EQ.'ON')WRITE(ICOUT,1121)J,I,AI,AICOEF,BICOEF,RSQ,POWERI 1121 FORMAT('J,I,AI,AICOEF,BICOEF,RSQ,POWERI = ',I8,I8,5E15.7) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C Y(J)=POWERI X(J)=FREQI D(J)=1.0 C 1110 CONTINUE NPLOTP=J NPLOTV=2 GOTO9000 1900 CONTINUE C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPEI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,IERROR,NPLOTP,NPLOTV 9012 FORMAT('ICASPL,IERROR,NPLOTP,NPLOTV = ',A4,2X,A4,2X,I8,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPER2(Y,X,N,IDATSW,CLWID,XSTART,XSTOP, CCCCC ADD FOLLOWING LINE SEPTEMBER 1998. 1IPPTBI, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C A PERCENT POINT 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--APRIL 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --OCTOBER 1978. C UPDATED --MARCH 1979. C UPDATED --APRIL 1979. C UPDATED --JANUARY 1981. C UPDATED --AUGUST 1981. C UPDATED --OCTOBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --APRIL 1982. C UPDATED --MAY 1982. C UPDATED --SEPTEMBER 1998. OPTION TO NOT BIN THE DATA C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IDATSW CHARACTER*4 IPPTBI CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C CCCCC DOUBLE PRECISION DSUM CCCCC DOUBLE PRECISION DN C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPPE' ISUBN2='R2 ' C IERROR='NO' C AN3=0.0 DENOM=0.0 C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPPER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(N.GE.2)GOTO49 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN DPPER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47) 47 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48) 48 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 49 CONTINUE C HOLD=X(1) DO60I=1,N IF(X(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPPER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL INPUT HORIZONTAL AXIS ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO80 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPPER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IDATSW,IPPTBI 71 FORMAT('IDATSW,IPPTBI = ',A4,1X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP 72 FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y(I),X(I) 74 FORMAT('I, Y(I), X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE 80 CONTINUE C C ********************************************** C ** STEP 2.0-- ** C ** HANDLE CASE FOR UNBINNED DATA ** C ********************************************** C IF(IPPTBI.EQ.'UNBI')THEN CALL SORT(X,N,X) DO91I=1,N Y2(I)=X(I) X2(I)=100.0*REAL(I)/N D2(I)=1.0 91 CONTINUE N2=N GOTO9000 ENDIF C C ********************************************** C ** STEP 2-- ** C ** IF NECESSARY, ** C ** DETERMINE CLASS WIDTH, ** C ** START VALUE, STOP VALUE, ** C ** AND NUMBER OF CLASSES. ** C ********************************************** C IF(IDATSW.EQ.'RAW')GOTO110 IF(IDATSW.EQ.'FREQ')GOTO150 C 110 CONTINUE IF(CLWID.NE.CPUMIN.AND.XSTART.NE.CPUMIN.AND. 1XSTOP.NE.CPUMAX)GOTO119 IWRIT2='OFF' CALL MEAN(X,N,IWRIT2,XMEAN,IBUGG3,IERROR) CALL SD(X,N,IWRIT2,XSD,IBUGG3,IERROR) IF(CLWID.EQ.CPUMIN)CLWID=0.3*XSD IF(XSTART.EQ.CPUMIN)XSTART=XMEAN-6.0*XSD IF(XSTOP.EQ.CPUMAX)XSTOP=XMEAN+6.0*XSD 119 CONTINUE GOTO180 C 150 CONTINUE CALL SORT(X,N,D2) NM1=N-1 CLWID=D2(2)-D2(1) DO160I=1,NM1 IP1=I+1 DELI=D2(IP1)-D2(I) IF(DELI.LT.CLWID)CLWID=DELI 160 CONTINUE XSTART=D2(1)-(CLWID/2.0) XSTOP=D2(N)+(CLWID/2.0) GOTO180 C 180 CONTINUE TOTWID=XSTOP-XSTART ANUMCL=TOTWID/CLWID NUMCLA=ANUMCL+1.0 C J=NUMCLA-1 AJ=J CLMAXJ=XSTART+AJ*CLWID ABSDEL=ABS(CLMAXJ-XSTOP) IF(ABSDEL.LE.0.0001)NUMCLA=NUMCLA-1 C C ******************************************************* C ** STEP 3-- ** C ** DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS ** C ******************************************************* C DO300J=1,NUMCLA D2(J)=0.0 300 CONTINUE C IF(IDATSW.EQ.'RAW')GOTO410 IF(IDATSW.EQ.'FREQ')GOTO510 C 410 CONTINUE DO420I=1,N DO430J=1,NUMCLA J2=J AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)GOTO440 430 CONTINUE GOTO420 440 CONTINUE D2(J2)=D2(J2)+1.0 420 CONTINUE C C FOR THIS RAW DATA CASE, C TREAT THE SPECIAL CASE OF EQUALITY C WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS C J=NUMCLA DO450I=1,N AJ=J CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(X(I).EQ.CLMAXJ)D2(J)=D2(J)+1.0 450 CONTINUE GOTO590 C 510 CONTINUE DO520I=1,N DO530J=1,NUMCLA J2=J AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)GOTO540 530 CONTINUE GOTO520 540 CONTINUE D2(J2)=D2(J2)+Y(I) 520 CONTINUE C C FOR THIS FREQUENCY DATA CASE, C TREAT THE SPECIAL CASE OF EQUALITY C WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS C (ALTHOUGH THIS SHOULD NOT HAPPEN WITH THE IDATSW = 'FREQ' CASE.) C J=NUMCLA DO550I=1,N AJ=J CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(X(I).EQ.CLMAXJ)D2(J)=D2(J)+Y(I) 550 CONTINUE GOTO590 C 590 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO595 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,591) 591 FORMAT('***** IN THE MIDDLE OF DPPER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,592)CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA 592 FORMAT('CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA= ',5E11.4,I8) CALL DPWRST('XXX','BUG ') DO593J=1,NUMCLA AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP FJ=D2(J) WRITE(ICOUT,594)J,CLMINJ,CLMAXJ,FJ 594 FORMAT('J,CLMINJ,CLMAXJ,FJ = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 593 CONTINUE 595 CONTINUE C C ********************************** C ** STEP 4-- ** C ** DETERMINE PLOT COORDINATES ** C ********************************** C 1100 CONTINUE SUM=0.0 DO1110J=1,NUMCLA FJ=D2(J) SUM=SUM+FJ 1110 CONTINUE AN3=SUM C DENOM=AN3 C K=0 SUM=0.0 DO1120J=1,NUMCLA K=K+1 AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP FJ=D2(J) SUM=SUM+FJ CUMFJ=SUM X2(K)=100.0*(CUMFJ/DENOM) Y2(K)=(CLMINJ+CLMAXJ)/2.0 1120 CONTINUE N2=K NPLOTV=2 C K=0 DO1130J=1,NUMCLA K=K+1 D2(K)=1.0 1130 CONTINUE GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N2 9012 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDATSW,AN3,DENOM 9013 FORMAT('IDATSW,AN3,DENOM = ',A4,2X,E15.8,E15.8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E11.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPERC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1CLLIMI,CLWIDT,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE THE FOLLOWING PLOT-- C A PERCENT POINT 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--APRIL 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --OCTOBER 1978. C UPDATED --APRIL 1979. C UPDATED --JANUARY 1981. C UPDATED --OCTOBER 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --SEPTEMBER 1998. OPTION TO NOT BIN THE DATA 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 IDATSW CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION CLLIMI(*) DIMENSION CLWIDT(*) C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C CCCCC ADD FOLLOWING LINE SEPTEMBER 1998. INCLUDE 'DPCOST.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='DPPE' ISUBN2='RC ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=2 C ICOLR=0 C C ************************************ C ** TREAT THE PERCENT POINT PLOT ** C ************************************ C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPERC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'POIN'.AND.IHARG(2).EQ.'PLOT') 1GOTO110 C IFOUND='NO' GOTO9000 C 110 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' ICASPL='PERC' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,IHLEF2,ICOLL,NLEFT 211 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPPERC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A PERCENT POINT 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 SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPPERC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ****************************************************** C ** STEP 5-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE NOT DATA POINTS ** C ** BUT ALREADY-COMPUTED FREQUENCIES, ** C ** AND THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE CORRESPONDING X VALUES FOR EACH ** C ** FREQUENCY. IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ****************************************************** C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IDATSW='RAW' IF(NUMV2.EQ.1)IDATSW='RAW' IF(NUMV2.EQ.1)GOTO590 IF(NUMV2.EQ.2)IDATSW='FREQ' IF(NUMV2.EQ.2)GOTO509 GOTO550 C 509 CONTINUE IHRIGH=IHARG(2) IHRIG2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,511)IHRIGH,IHRIG2,ICOLR,NRIGHT 511 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NRIGHT.NE.NLEFT)GOTO570 GOTO590 C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPPERC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A PERCENT POINT PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) 559 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 560 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562)NUMV2 562 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,563) 563 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,564)(IANS(I),I=1,IWIDTH) 564 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPPERC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A PERCENT POINT PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578) 578 FORMAT(' WHEN HAVE 2 VARIABLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,580) 580 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' THE FIRST VARIABLE (FREQUENCIES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584)IHLEFT,IHLEF2,NLEFT 584 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE SECOND VARIABLE (HORIZ. AXIS VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586)IHRIGH,IHRIG2,NRIGHT 586 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH) 588 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ***************************************** C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ** AND CARRY OUT THE PLOTS. ** C ***************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 C IF(NUMV2.LE.1)GOTO651 GOTO652 C 651 CONTINUE IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)X1(J)=TAGPLO(I) GOTO660 C 652 CONTINUE IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLR.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)X1(J)=TAGPLO(I) IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) GOTO660 C 660 CONTINUE NLOCAL=J C C **************************************************************** C ** STEP 7-- C ** DETERMINE IF THE ANALYST C ** HAS SPECIFIED 1) THE CLASS WIDTH, C ** 2) THE MIN POINT OF THE FIRST CELL, C ** 3) THE MAX POINT OF THE LAST CELL, C ** FOR THE DISTRIBUTIONAL ANALYSIS. C ** IF NON-DEFAULT, USE THE SPECIFIED VALUES. C ** IF DEFAULT, USE THE DEFAULT VALUES-- C ** 1) CLASS WIDTH = .3 OF A SAMPLE STANDARD DEVIATION; C ** 2) START = SAMPLE MEAN - 6*(SAMPLE STANDARD DEVIATION); C ** 3) STOP = SAMPLE MEAN + 6*(SAMPLE STANDARD DEVIATION); C ** NOTE THAT THE DEFAULT SETTINGS ARE IN FACT C **************************************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CLWID=CLWIDT(1) XSTART=CLLIMI(1) XSTOP=CLLIMI(2) C C ***************************************************** C ** STEP 8-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C CALL DPPER2(Y1,X1,NLOCAL,IDATSW,CLWID,XSTART,XSTOP, CCCCC ADD FOLLOWING LINE SEPTEMBER 1998. 1IPPTBI, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPERC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)CLWID,XSTART,XSTOP 9014 FORMAT('CLWID,XSTART,XSTOP = ',3E15.7) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9090 DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPERI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM C 1) AUTOPERIODOGRAM C 2) CO-PERIODOGRAM; C 3) QUADRATURE PERIODOGRAM; C 4) CROSS-PERIODOGRAM (CO-PERIODOGRAM AND QUADRATURE-PERIODOGRAM) 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 --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHVA21 CHARACTER*4 IHVA22 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPPE' ISUBN2='RI ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=2 C ICOLV2=0 C C **************************************************************** C ** TREAT THE FOLLOWING CASES-- * C ** 1) AUTOPERIODOGRAM * C ** 2) CO-PERIODOGRAM; * C ** 3) QUADRATURE PERIODOGRAM; * C ** 4) CROSS-PERIODOGRAM (CO-PERIODOGRAM AND QUAD-PERI); * 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 DPPERI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)MAXCOL 54 FORMAT('MAXCOL = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ************************************************* C ** STEP 1.1-- ** C ** SEARCH FOR PERIODOGRAM OR AUTOPERIODOGRAM ** C ************************************************* C ICASPL='AUPE' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.IHARG(1).EQ.'PERI'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.IHARG(1).EQ.'PERI'.AND.IHARG(2).NE.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'PERI'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'PERI'.AND.IHARG(1).NE.'PLOT') 1GOTO110 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'PERI'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'PERI'.AND.IHARG(1).NE.'PLOT') 1GOTO110 C C ******************************** C ** STEP 1.2-- ** C ** SEARCH FOR COPERIODOGRAM ** C ******************************** C ICASPL='COPE' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CO'.AND.IHARG(1).EQ.'PERI'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CO'.AND.IHARG(1).EQ.'PERI'.AND.IHARG(2).NE.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'COPE'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'COPE'.AND.IHARG(1).NE.'PLOT') 1GOTO110 C C ***************************************** C ** STEP 1.3-- ** C ** SEARCH FOR QUADRATURE PERIODOGRAM ** C ***************************************** C ICASPL='QUPE' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'QUAD'.AND.IHARG(1).EQ.'PERI'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'QUAD'.AND.IHARG(1).EQ.'PERI'.AND.IHARG(2).NE.'PLOT') 1GOTO111 C C ************************************ C ** STEP 1.4-- ** C ** SEARCH FOR CROSS-PERIODOGRAM ** C ************************************ C ICASPL='CRPE' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'PERI'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'PERI'.AND.IHARG(2).NE.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'CROS'.AND.ICOM2.EQ.'SPER'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'CROS'.AND.ICOM2.EQ.'SPER'.AND.IHARG(1).NE.'PLOT') 1GOTO110 C ICASPL=' ' C IFOUND='NO' GOTO9000 C 110 CONTINUE ILASTC=0 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 112 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(ICASPL.EQ.'AUPE')GOTO270 IF(ICASPL.EQ.'COPE')GOTO280 IF(ICASPL.EQ.'QUPE')GOTO280 IF(ICASPL.EQ.'CRPE')GOTO280 C 260 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,261) 261 FORMAT('***** INTERNAL ERROR IN DPPERI') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,262) 262 FORMAT(' AT BRANCH POINT 261--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,263) 263 FORMAT(' ICASPL NOT EQUAL ONE OF THE ALLOWABLE 4--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,264) 264 FORMAT(' AUPE, COPE, QUPE, OR CRPE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,266)ICASPL 266 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,267) 267 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,268)(IANS(I),I=1,IWIDTH) 268 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 270 CONTINUE MAXV2=1 GOTO290 C 280 CONTINUE MAXV2=2 GOTO290 C 290 CONTINUE C C ******************************************** C ** STEP 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) C C *********************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *********************************************************** C ISTEPN='4' 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 DPPERI--') 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 PERIODOGRAM ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' IS TO BE 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(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASQ='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 ICASQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C *********************************************** C ** STEP 6-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF VARIABLES ** C ** (EXACTLY 1 ** C ** FOR AN AUTOPERIODOGRAM ANALYSIS; ** C ** EXACTLY 2 ** C ** FOR A CROSS-PERIODOGRAM ANALYSIS. ** C ** ALSO, FOR A CROSS-PERIODOGRAM ANALYSIS, ** C ** CHECK THE VALIDITY ** C ** OF THE SECOND VARIABLE. ** C ** DOES THE NAME EXIST IN THE TABLE? ** C ** DOES THE NUMBER OF ELEMENTS ** C ** IN THE SECOND VARIABLE ** C ** AGREE WITH THE NUMBER OF ELEMENTS ** C ** IN THE FIRST VARIABLE? ** C *********************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(1.LE.NUMV2.AND.NUMV2.LE.MAXV2)GOTO509 GOTO550 C 509 CONTINUE IF(NUMV2.LE.1)GOTO590 IHVA21=IHARG(2) IHVA22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVA21,IHVA22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLV2=IVALUE(ILOCV) NVAR2=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,511)IHVA21,IHVA22,ICOLV2,NVAR2 511 FORMAT('IHVA21,IHVA22,ICOLV2,NVAR2 = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NVAR2.NE.NLEFT)GOTO570 GOTO590 C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPPERI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A CROSS-PERIODOGRAM ANALYSIS, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553) 553 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' MUST BE EXACTLY 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556) 556 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557)NUMV2 557 FORMAT(' OF VARIABLES WAS ',I8) 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 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPPERI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A CROSS-PERIODOGRAM ANALYSIS, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,573) 573 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,574) 574 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,575) 575 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576) 576 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,577)IHLEFT,IHLEF2,NLEFT 577 FORMAT(' THE FIRST VARIABLE ', 1'(',A4,A4,') HAS ',I8, 'ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578)IHVA21,IHVA22,NVAR2 578 FORMAT(' THE SECOND VARIABLE ', 1'(',A4,A4,') HAS ',I8, 'ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,580)(IANS(I),I=1,IWIDTH) 580 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ********************************************** C ** STEP 7-- ** C ** FORM THE VARIABLE Y1(.) ** C ** WHICH WILL CONTAIN THE FIRST VARIABLE; ** C ** ALSO, FOR A CROSS-PERIODOGRAM ANALYSIS, ** C ** FORM THE VARIABLE Y2(.) ** C ** WHICH WILL CONTAIN THE SECOND VARIABLE. ** C ** FORM THESE VARIABLES BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASQ.EQ.'FULL')GOTO610 IF(ICASQ.EQ.'SUBS')GOTO620 IF(ICASQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE IF(NQ.GE.MINN2)GOTO660 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,651) 651 FORMAT('***** ERROR IN DPPERI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,652) 652 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,653)IHLEFT,IHLEF2 653 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,654) 654 FORMAT(' (FOR WHICH AN AUTO OR CROSS-PERIODOGRAM ', 1'ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,655) 655 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,656)MINN2 656 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,657) 657 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,658) 658 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,659)(IANS(I),I=1,IWIDTH) 659 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 660 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO670I=1,IMAX IF(ISUB(I).EQ.0)GOTO670 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(IBUGG2.EQ.'ON')WRITE(ICOUT,666)I,J,IJ,ICOLL,MAXCOL,MAXN,V(IJ) 666 FORMAT('I,J,IJ,ICOLL,MAXCOL,MAXN,V(IJ) = ',6I8,E15.7) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) IF(MAXV2.LE.1)GOTO670 C IJ=MAXN*(ICOLV2-1)+I IF(ICOLV2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLV2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLV2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLV2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLV2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLV2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLV2.EQ.MAXCP6)Y2(J)=TAGPLO(I) C 670 CONTINUE NS=J C C C **************************************************************** C ** STEP 9-- * C ** FORM THE VERTICAL AND HORIZONTAL AXIS * C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. * C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . * C ** THIS WILL BE ALL ONES FOR ALL 7 CASES EXCEPT * C ** WHEN THE COMMAND CROSS-SPECTRUM IS ENTERED * C ** WHICH WILL RESULT IN 2 SUPERIMPOSED CURVES-- * C ** THE CO-SPECTRUM AND THE QUADRATURE SPECTRUM * C ** AND SO D(.) WILL RETURN WITH ALL ONES FOR C ** THE CO-SPECTRUM PART, AND ALL TWOS * C ** FOR THE QUADRATURE SPECTRUM PART. * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C **************************************************************** C ISTEPN='9' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPPEI2(Y1,Y2,NS,ICASPL,MAXN, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPERI--') 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 DPPESZ(IHARG,IARGT,ARG,NUMARG, 1PDEPSZ,PPEDSZ, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE SIZE FOR THE 3-D PEDESTAL. C THE SIZE FOR THE PEDESTAL WILL BE PLACED C IN THE FLOATING POINT VARIABLE PPEDSZ. C THE SIZE FOR THE PEDESTAL WILL BE C IN UNITS OF THE Z AXIS VARIABLE. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --PDEPSZ C OUTPUT ARGUMENTS--PPEDSZ 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 PEDESTAL 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--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 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.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 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPPESZ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL SYNTAX FOR THE PEDESTAL SIZE ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER SYNTAX--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE THE Z AXIS DATA RANGES FROM ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' 500 TO 2000 (FOR A DIFFERENCE OF 1500 UNITS), ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' AND SUPPOSE THE ANALYST WISHES THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' PLOT PEDESTAL TO HAVE A HEIGHT OF ABOUT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) 1129 FORMAT(' 200 SUCH UNITS; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' THEN THE PROPER SYNTAX IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' PEDESTAL SIZE 200 ') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE PPEDSZ=PDEPSZ GOTO1180 C 1160 CONTINUE PPEDSZ=ARG(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)PPEDSZ 1181 FORMAT('THE (3-D) PEDESTAL SIZE (HEIGHT) ', 1'HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPHD(ICASAN, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) C ***** ***** C PURPOSE--CARRY OUT A (YATES) PHD ANALYSIS C (USEFUL FOR COMPUTING THE EFFECTS IN A 2**K C AND A 2**(K-P) EXPERIMENT) C NOTE--THIS CODE ASSUMES THE DATA IS IN C STANDARD YATES/HUNTER/BOX ORDER. C FOR EXAMPLE, FOR A 2**3-- C - - - C + - - C - + - C + + - C - - + C + - + C - + + C + + + C NOTE--IF HAVE REPLICATION, THEN THE REPLICATES C MAY EITHER BE IMMEDIATELY WITHIN C OR MAY BE IN BLOCKS AFTER. C EXAMPLE--PHD Y C PHD Y SET C PHD ANALYSIS Y C PHD ANALYSIS Y SET C DEX FIT Y C DEX FIT Y REP C 2**K DEX FIT Y C 2**K DEX FIT Y REP C + OTHER COMBINATIONS OF SYNONYMS C NOTE--IF THERE ARE NO REPLICATIONS IN THE DATA, C THEN THIS COMMAND TAKES 1 ARGUMENT. C IF HAVE REPLCATION, C THEN THIS COMMAND TAKES 2 ARGUMENTS 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/7 C ORIGINAL VERSION--SEPTEMBER 1993. C UPDATED --JUNE 1989. SYNONYM = (2**K) DEX FIT C UPDATED --NOVEMBER 1989. SELECTIVE PRINTING OF COEF C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C MOVE SOME DPPHD2 DIMENSIONS TO DPPHD C UPDATED --NOVEMBER 1991. ALLOW 2**1 ANALYSIS C UPDATED --APRIL 1992. DEFINE CUTOFF C UPDATED --APRIL 1992. DELETE MAXNPP C UPDATED --APRIL 1992. DELETE NPLOTP,X(.),Y(.),D(.) C UPDATED --FEBRUARY 1995. RENAME COMMAND TO DEX PHD, C MINOR BUG FIX C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASAN C CCCCC THE FOLLOWING LINE WAS COMMENTED OUT APRIL 1992 CCCCC CHARACTER*4 IANGLU CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASEQ C CHARACTER*4 IHRI11 CHARACTER*4 IHRI12 CHARACTER*4 IHRI21 CHARACTER*4 IHRI22 CCCCC CHARACTER*4 IHRI31 CCCCC CHARACTER*4 IHRI32 CCCCC CHARACTER*4 IHRI41 CCCCC CHARACTER*4 IHRI42 CHARACTER*4 IHRIX1 CHARACTER*4 IHRIX2 C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IERRO4 C CHARACTER*4 ICTAR1 CHARACTER*4 ICTAR2 C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 (ALAN) INCLUDE 'DPCOHO.INC' C DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) C DIMENSION COEF(MAXOBV) DIMENSION SSQCOE(MAXOBV) DIMENSION TCOEF(MAXOBV) DIMENSION RSDCOE(MAXOBV) DIMENSION TAGCOE(MAXOBV) DIMENSION TAGCO2(MAXOBV) C CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' INCLUDE 'DPCOZI.INC' DIMENSION REPD(MAXOBV) DIMENSION IFLAG(MAXOBV) DIMENSION RSDCOC(MAXOBV) DIMENSION ITAG(MAXOBV) DIMENSION ITAGCO(MAXOBV) DIMENSION YMEAN(MAXOBV) DIMENSION YVAR(MAXOBV) DIMENSION DUMMY(MAXOBV) DIMENSION DUMMY2(MAXOBV) DIMENSION AINDEX(MAXOBV) DIMENSION AINDE2(MAXOBV) DIMENSION TEMP(MAXOBV) EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(1)) EQUIVALENCE (GARBAG(IGARB3),COEF(1)) EQUIVALENCE (GARBAG(IGARB4),SSQCOE(1)) EQUIVALENCE (GARBAG(IGARB5),TCOEF(1)) EQUIVALENCE (GARBAG(IGARB6),RSDCOE(1)) EQUIVALENCE (GARBAG(IGARB7),TAGCOE(1)) EQUIVALENCE (GARBAG(IGARB8),TAGCO2(1)) EQUIVALENCE (GARBAG(IGARB9),REPD(1)) EQUIVALENCE (GARBAG(IGAR10),RSDCOC(1)) EQUIVALENCE (G2RBAG(IGAR11),YMEAN(1)) EQUIVALENCE (G2RBAG(IGAR12),YVAR(1)) EQUIVALENCE (G2RBAG(IGAR13),DUMMY(1)) EQUIVALENCE (G2RBAG(IGAR14),DUMMY2(1)) EQUIVALENCE (G2RBAG(IGAR15),AINDEX(1)) EQUIVALENCE (G2RBAG(IGAR16),AINDE2(1)) EQUIVALENCE (G2RBAG(IGAR17),TEMP(1)) EQUIVALENCE (IGARBG(IIGAR1),IFLAG(1)) EQUIVALENCE (IGARBG(IIGAR2),ITAG(1)) EQUIVALENCE (IGARBG(IIGAR3),ITAGCO(1)) CCCCC END CHANGE C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' CCCCC THE FOLLOWING LINE WAS INSERTED NOVEMBER 1989 INCLUDE 'DPCODE.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='DPPH' ISUBN2='D ' C IFOUND='NO' IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MINN2=2 C IWRITE='YES' C CCCCC THE FOLLOWING 4 LINES WERE ADDED APRIL 1992 (ALAN) ICUTMX=NUMBPW IF(IHOST1.EQ.'CDC '.OR.IHOST1.EQ.'CYBE')ICUTMX=48 IF(IHOST1.EQ.'205 ')ICUTMX=48 CUTOFF=2**(ICUTMX-3) C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'PHD ')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPHD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASAN 53 FORMAT('ICASAN = ',A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE FIXED APRIL 1992 CCCCC WRITE(ICOUT,54)IANGLU,IBUGA2,IBUGA3,IBUGQ CCC54 FORMAT('IANGLU,IBUGA2,IBUGA3,IBUGQ = ', CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGA2,IBUGA3,IBUGQ 54 FORMAT('IBUGA2,IBUGA3,IBUGQ = ', 1A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)ICASAN,MAXN 56 FORMAT('ICASAN,MAXN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IFOUND,IERROR 57 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE COMMENTED OUT APRIL 1992 CCCCC WRITE(ICOUT,58)MAXNPP CCC58 FORMAT('MAXNPP = ',I8) CCCCC CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE INSERTED NOVEMBER 1989 WRITE(ICOUT,61)YATCCU,YATTCU,YATRCU,IYATOS,IYATRS 61 FORMAT('YATCCU,YATTCU,YATRCU,IYATOS,IYATRS = ',3E15.7, 12X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************* C ** TREAT THE (YATES) PHD ANALYSIS CASE ** C ************************************* C C *************************** C ** STEP 11-- ** C ** EXTRACT THE COMMAND ** C *************************** C CCCCC FEBRUARY 1995. RENAME COMMAND FROM PHD TO DEX PHD CCCCC ACCEPTED SYNONYMS ARE: CCCCC DEX PHD CCCCC DEX PHD ANALYSIS CCCCC DEX PHD FIT CCCCC PHD DEX CCCCC PHD DEX ANALYSIS CCCCC PHD DEX FIT ISTEPN='11' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC FEBRUARY 1995. MODIFY FOLLOWING SECTION CCCCC IF(NUMARG.GE.1.AND. CCCCC1IHARG(1).EQ.'ANAL'.AND.IHARG2(1).EQ.'YSIS')GOTO1110 CCCCC THE FOLLOWING 5 LINES WERE ADDED JUNE 1989 CCCCC IF(NUMARG.GE.1.AND. CCCCC1IHARG(1).EQ.'FIT')GOTO1110 CCCCC IF(NUMARG.GE.2.AND. CCCCC1IHARG(1).EQ.'DEX'.AND. CCCCC1IHARG(2).EQ.'FIT')GOTO1120 C IF(ICOM.EQ.'DEX')THEN IF(NUMARG.GE.2.AND. 1 IHARG(1).EQ.'PHD'.AND. 1 IHARG(2).EQ.'ANAL'.AND.IHARG2(2).EQ.'YSIS')GOTO1120 IF(NUMARG.GE.2.AND. 1 IHARG(1).EQ.'PHD'.AND. 1 IHARG(2).EQ.'FIT')GOTO1120 IF(NUMARG.GE.1.AND. 1 IHARG(1).EQ.'PHD')GOTO1110 ENDIF IF(ICOM.EQ.'PHD')THEN IF(NUMARG.GE.2.AND. 1 IHARG(1).EQ.'DEX'.AND. 1 IHARG(2).EQ.'ANAL'.AND.IHARG2(2).EQ.'YSIS')GOTO1120 IF(NUMARG.GE.2.AND. 1 IHARG(1).EQ.'DEX'.AND. 1 IHARG(2).EQ.'FIT')GOTO1120 IF(NUMARG.GE.1.AND. 1 IHARG(1).EQ.'DEX')GOTO1110 ENDIF C GOTO1190 C 1110 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO1190 C CCCCC THE FOLLOWING 4 LINES WERE ADDED JUNE 1989 1120 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO1190 C 1190 CONTINUE IFOUND='YES' CCCCC THE FOLLOWING LINE WAS CHANGED JUNE 1989 CCCCC ICASAN='PHD ' ICASAN='DEXF' C C ******************************************************** C ** STEP 12-- ** C ** CARRY OUT A GENERAL CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE 1 OR 2). ** C ******************************************************** C ISTEPN='12' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 13-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='13' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1390 DO1300J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO1310 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO1310 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO1320 1300 CONTINUE GOTO1390 1310 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1390 1320 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1390 1390 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'PHD ')GOTO1395 WRITE(ICOUT,1391)ICASEQ,NUMARG,ILOCQ 1391 FORMAT('ICASEQ,NUMARG,ILOCQ = ',A4,2X,2I8) CALL DPWRST('XXX','BUG ') 1395 CONTINUE C C ******************************************************** C ** STEP 14-- ** C ** CARRY OUT A SPECIFIC CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE 1 OR 2). ** C ******************************************************** C ISTEPN='14' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=ILOCQ-1 IF(NUMVAR.EQ.1)GOTO1490 IF(NUMVAR.EQ.2)GOTO1490 GOTO1410 C 1410 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPPHD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412) 1412 FORMAT(' FOR A YATES PHD ANALYSIS, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1418) 1418 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1419) 1419 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1420) 1420 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1421) 1421 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1422)NUMVAR 1422 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1423) 1423 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1424)(IANS(I),I=1,IWIDTH) 1424 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1490 CONTINUE C C **************************************************************** C ** STEP 15-- * C ** EXAMINE THE VARIABLES-- * C ** HAS EACH VARIABLE * C ** ALREADY BEEN DEFINED? * C ** NOTE THAT ILISR1, ILISR2, * C ** IS THE LINE IN THE TABLE * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C ** NOTE THAT ICOLR1, ICOLR2, * C ** IS THE DATA COLUMN (1 TO 10+6) * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C **************************************************************** C ISTEPN='15' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICTAR1='FIRS' ICTAR2='T ' ILOCR1=1 IHRI11=IHARG(ILOCR1) IHRI12=IHARG2(ILOCR1) IHRIX1=IHRI11 IHRIX2=IHRI12 DO1510I=1,NUMNAM I2=I IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1519 IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1510 CONTINUE GOTO1570 1519 CONTINUE ILISR1=I2 ICOLR1=IVALUE(ILISR1) NIRIG1=IN(ILISR1) C IF(NUMVAR.LE.1)GOTO1590 ICTAR1='SECO' ICTAR2='ND ' ILOCR2=2 IHRI21=IHARG(ILOCR2) IHRI22=IHARG2(ILOCR2) IHRIX1=IHRI21 IHRIX2=IHRI22 DO1520I=1,NUMNAM I2=I IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1529 IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1520 CONTINUE GOTO1570 1529 CONTINUE ILISR2=I2 ICOLR2=IVALUE(ILISR2) NIRIG2=IN(ILISR2) GOTO1590 C 1560 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1561) 1561 FORMAT('***** ERROR IN DPPHD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1562)ICTAR1,ICTAR2 1562 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1565) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1563)IHRIX1,IHRIX2 1563 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') 1565 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,') WRITE(ICOUT,1566) 1566 FORMAT(' BUT AS A PARAMETER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1567) 1567 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1568) 1568 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1569)(IANS(I),I=1,IWIDTH) 1569 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1571) 1571 FORMAT('***** ERROR IN DPPHD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1572)ICTAR1,ICTAR2 1572 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1573)IHRIX1,IHRIX2 1573 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1575) 1575 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1576) 1576 FORMAT(' OF AVAILABLE VARIABLE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1577)IHRI11,IHRI12 1577 FORMAT(' THE VARIABLE IN QUESTION WAS ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1578) 1578 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1579)(IANS(I),I=1,IWIDTH) 1579 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1590 CONTINUE C C ****************************************************** C ** STEP 22-- ** C ** CHECK THAT VARIABLES 1 AND 2 HAVE ** C ** THE SAME NUMBER OF ELEMENTS. ** C ****************************************************** C 2100 CONTINUE ISTEPN='21' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMVAR.LE.1)GOTO2190 IF(NIRIG1.EQ.NIRIG2)GOTO2190 C 2110 CONTINUE WRITE(ICOUT,2111) 2111 FORMAT('***** ERROR IN DPPHD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2113) 2113 FORMAT(' THE NUMBER OF OBSERVATIONS IN VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2114) 2114 FORMAT(' 1 AND 2 MUST BE THE SAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2115) 2115 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2116)IHRI11,IHRI12,NIRIG1 2116 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2117)IHRI21,IHRI22,NIRIG2 2117 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2120) 2120 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2121)(IANS(I),I=1,IWIDTH) 2121 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2190 CONTINUE C C ********************************************* C ** STEP 32-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ** BRANCH TO THE PROPER CASE. ** C ********************************************* C ISTEPN='32' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NLOCAL=NIRIG1 C IF(ICASEQ.EQ.'FULL')GOTO3210 IF(ICASEQ.EQ.'SUBS')GOTO3220 IF(ICASEQ.EQ.'FOR')GOTO3230 C 3210 CONTINUE DO3215I=1,NLOCAL ISUB(I)=1 3215 CONTINUE NQ=NLOCAL GOTO3250 C 3220 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO3250 C 3230 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR GOTO3250 C 3250 CONTINUE IF(NQ.GE.MINN2)GOTO3290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3251) 3251 FORMAT('***** ERROR IN DPPHD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3252) 3252 FORMAT(' AFTER THE APPROPRIATE SUBSET ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3253) 3253 FORMAT(' HAS BEEN EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3254)IHRI11,IHRI12 3254 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3255) 3255 FORMAT(' (FOR WHICH AN YATES PHD ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3256) 3256 FORMAT(' IS TO BE PERFORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3257)MINN2 3257 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3258)NQ 3258 FORMAT(' SUCH WAS NOT THE CASE HERE (NQ = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3259) 3259 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3260)(IANS(I),I=1,IWIDTH) 3260 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3290 CONTINUE C C ********************************************** C ** STEP 33-- ** C ** FORM THE SUBSETTED VARIABLES ** C ** Y1(.) ** C ** Y2(.) ** C ** CONTAINING ** C ** THE RESPONSE VARIABLE ** C ** THE REPLICATION-TAG VARIABLE ** C ** RESPECTIVELY. ** C ********************************************** C ISTEPN='33' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 IMAX=NIRIG1 IF(NQ.LT.NIRIG1)IMAX=NQ IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1WRITE(ICOUT,780)N,NIRIG1,NQ,IMAX 780 FORMAT(' N,NIRIG1,NQ,IMAX = ',4I8) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL DPWRST('XXX','BUG ') DO3300I=1,IMAX IF(ISUB(I).EQ.0)GOTO3300 J=J+1 C IJ=MAXN*(ICOLR1-1)+I IF(ICOLR1.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLR1.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLR1.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLR1.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLR1.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLR1.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLR1.EQ.MAXCP6)Y1(J)=TAGPLO(I) C IF(NUMVAR.LE.1)Y2(J)=1.0 IF(NUMVAR.LE.1)GOTO3300 IJ=MAXN*(ICOLR2-1)+I IF(ICOLR2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLR2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLR2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLR2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLR2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLR2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLR2.EQ.MAXCP6)Y2(J)=TAGPLO(I) C 3300 CONTINUE NS=J IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1WRITE(ICOUT,776)J,NS 776 FORMAT('J,NS = ',2I8) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL DPWRST('XXX','BUG ') C C ********************************************* C ** STEP 34-- ** C ** CHECK TO MAKE SURE THAT THE ** C ** SUBSETTING DOES NOT RESULT IN ** C ** TOO FEW DATA POINTS RESULTING ** C ** (AT LEAST 2) ** C ** WITH WHICH TO DO A YATES PHD ANALYSIS. ** C ********************************************* C ISTEPN='34' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICOUNT=0 IF(NS.LE.2)ICOUNT=NS IF(NS.LE.2)GOTO3410 DO3400I=1,NS CCCCC WRITE(ICOUT,777)I,ICOUNT,NS,MINN2,Y2(I) CC777 FORMAT('I,ICOUNT,NS,MINN2,Y2(I) = ',I8,E15.7) CCCCC CALL DPWRST('XXX','BUG ') IF(Y2(I).LE.-0.0001.OR.Y2(I).GE.0.0001)ICOUNT=ICOUNT+1 3400 CONTINUE 3410 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED NOVEMBER 1991 CCCCC IF(ICOUNT.LE.MINN2)GOTO3450 IF(ICOUNT.LT.MINN2)GOTO3450 GOTO3490 C 3450 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3451) 3451 FORMAT('***** ERROR IN DPPHD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3452) 3452 FORMAT(' AFTER THE SPECIFIED SUBSETTING ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3453) 3453 FORMAT(' HAS BEEN DONE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3454)IHRI11,IHRI12 3454 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3455) 3455 FORMAT(' (FOR WHICH A YATES PHD ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3456) 3456 FORMAT(' IS TO BE PERFORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3457)MINN2 3457 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3458)ICOUNT 3458 FORMAT(' SUCH WAS NOT THE CASE HERE (ICOUNT = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3459) 3459 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3460)(IANS(I),I=1,IWIDTH) 3460 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3490 CONTINUE C C *************************************** C ** STEP 41-- ** C ** CARRY OUT THE YATES PHD ANALYSIS ** C *************************************** C ISTEPN='41' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PHD ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC JUNE, 1990. MOVE SOME DIMENSIONS FROM DPPHD2 TO DPPHD CALL DPPHD2(Y1,Y2,NS,ICASAN,MAXN,IWRITE, CCCCC THE FOLLOWING LINE WAS INSERTED NOVEMBER 1989 1YATCCU,YATTCU,YATRCU,IYATOS,IYATRS, 1COEF,SSQCOE,TCOEF,RSDCOE,TAGCOE,TAGCO2,NCOEF, 1PRESSD,PRESDF,REPSD,REPDF,REFSD,REFDF,SDCOEF, 1REPD,IFLAG,RSDCOC,ITAG,ITAGCO,YMEAN, 1YVAR,DUMMY,DUMMY2,AINDEX,AINDE2,TEMP, 1IBUGA3,ISUBRO,IERROR) C C *************************************** C ** STEP 51-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='51' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) NPASS=7 DO5100IPASS=1,NPASS IF(IPASS.EQ.1)IH='PRES' IF(IPASS.EQ.1)IH2='SD ' IF(IPASS.EQ.2)IH='PRES' IF(IPASS.EQ.2)IH2='DF ' IF(IPASS.EQ.3)IH='REPS' IF(IPASS.EQ.3)IH2='D ' IF(IPASS.EQ.4)IH='REPD' IF(IPASS.EQ.4)IH2='F ' IF(IPASS.EQ.5)IH='REFS' IF(IPASS.EQ.5)IH2='D ' IF(IPASS.EQ.6)IH='REFD' IF(IPASS.EQ.6)IH2='F ' IF(IPASS.EQ.7)IH='SDCO' IF(IPASS.EQ.7)IH2='EF ' C DO5150I=1,NUMNAM I2=I IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO5180 5150 CONTINUE IF(NUMNAM.LT.MAXNAM)GOTO5170 WRITE(ICOUT,5151) 5151 FORMAT('***** ERROR IN DPPHD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5152) 5152 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5153)MAXNAM 5153 FORMAT(' NAMES MUST BE AT MOST ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5154) 5154 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5155) 5155 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5156) 5156 FORMAT(' HAS JUST EXCEEDED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5157) 5157 FORMAT(' SUGGESTED ACTION--ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5158) 5158 FORMAT(' TO DETERMINE THE IMPORTANT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5159) 5159 FORMAT(' (VERSUS UNIMPORTANT) VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5160) 5160 FORMAT(' AND PARAMETERS, AND THEN REUSE SOME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5161) 5161 FORMAT(' OF THE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5162) 5162 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5163)(IANS(I),I=1,IWIDTH) 5163 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 5170 CONTINUE NUMNAM=NUMNAM+1 ILOC=NUMNAM IHNAME(ILOC)=IH IHNAM2(ILOC)=IH2 IUSE(ILOC)='P' IF(IPASS.EQ.1)VALUE(ILOC)=PRESSD IF(IPASS.EQ.2)VALUE(ILOC)=PRESDF IF(IPASS.EQ.3)VALUE(ILOC)=REPSD IF(IPASS.EQ.4)VALUE(ILOC)=REPDF IF(IPASS.EQ.5)VALUE(ILOC)=REFSD IF(IPASS.EQ.6)VALUE(ILOC)=REFDF IF(IPASS.EQ.7)VALUE(ILOC)=SDCOEF VAL=VALUE(ILOC) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(ILOC)=IVAL GOTO5100 C 5180 CONTINUE IF(IPASS.EQ.1)VALUE(I2)=PRESSD IF(IPASS.EQ.2)VALUE(I2)=PRESDF IF(IPASS.EQ.3)VALUE(I2)=REPSD IF(IPASS.EQ.4)VALUE(I2)=REPDF IF(IPASS.EQ.5)VALUE(I2)=REFSD IF(IPASS.EQ.6)VALUE(I2)=REFDF IF(IPASS.EQ.7)VALUE(I2)=SDCOEF VAL=VALUE(I2) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(I2)=IVAL GOTO5100 C 5100 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'PHD ')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPHD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASAN 9013 FORMAT('ICASAN = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)MAXN,NUMVAR 9014 FORMAT('MAXN,NUMVAR = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NIRIG1,NIRIG2 9015 FORMAT('NIRIG1,NIRIG2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NLOCAL,NQ,MINN2 9016 FORMAT('NLOCAL,NQ,MINN2 = ',3I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 6 LINES WERE COMMENTED OUT APRIL 1992 CCCCC IF(NPLOTP.LE.0)GOTO9029 CCCCC DO9020I=1,NPLOTP CCCCC WRITE(ICOUT,9021)I,Y(I),X(I),D(I) C9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CCCCC CALL DPWRST('XXX','BUG ') C9020 CONTINUE C9029 CONTINUE WRITE(ICOUT,9031)ICOUNT 9031 FORMAT('ICOUNT = ',I8) CALL DPWRST('XXX','BUG ') DO9050I=1,NIRIG1 WRITE(ICOUT,9051)I,Y1(I),Y2(I),ISUB(I) 9051 FORMAT('I,Y1(I),Y2(I),ISUB(I) = ',I8,2E15.7,I8) CALL DPWRST('XXX','BUG ') 9050 CONTINUE WRITE(ICOUT,9061)IHRI11,IHRI12 9061 FORMAT('IHRI11,IHRI12 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9062)IHRI21,IHRI22 9062 FORMAT('IHRI21,IHRI22 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE INSERTED NOVEMBER 1989 WRITE(ICOUT,9071)YATCCU,YATTCU,YATRCU,IYATOS,IYATRS 9071 FORMAT('YATCCU,YATTCU,YATRCU,IYATOS,IYATRS = ',3E15.7, 12X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPHD2(Y,REP,N,ICASPL,MAXN,IWRITE, 1YATCCU,YATTCU,YATRCU,IYATOS,IYATRS, 1COEF,SSQCOE,TCOEF,RSDCOE,TAGCOE,TAGCO2,NCOEF, 1PRESSD,PRESDF,REPSD,REPDF,REFSD,REFDF,SDCOEF, 1REPD,IFLAG,RSDCOC,ITAG,ITAGCO,YMEAN, 1YVAR,DUMMY,DUMMY2,AINDEX,AINDE2,TEMP, 1IBUGA3,ISUBRO,IERROR) C C PURPOSE--CARRY OUT A (YATES) PHD ANALYSIS (DEX FIT FOR 2**K DESIGNS) C (USEFUL FOR COMPUTING THE EFFECTS IN A 2**K C AND A 2**(K-P) EXPERIMENT) C NOTE--THIS CODE ASSUMES THE DATA IS IN C STANDARD YATES/HUNTER/BOX ORDER. C FOR EXAMPLE, FOR A 2**3-- C - - - C + - - C - + - C + + - C - - + C + - + C - + + C + + + C NOTE--IF HAVE REPLICATION, THEN THE REPLICATES C MAY EITHER BE IMMEDIATELY WITHIN C OR MAY BE IN BLOCKS AFTER. C EXAMPLE--PHD Y C PHD Y REP C PHD ANALYSIS Y C PHD ANALYSIS Y REP C DEX FIT Y C DEX FIT Y REP 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/7 C ORIGINAL VERSION--SEPTEMBER 1993. C UPDATED --FEBRUARY 1995. C UPDATED --AUGUST 1995. REPLACE NUMERICAL RECIPE C ROUTINE WITH CMLIB ROUTINE C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IWRITE C CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IREP CHARACTER*4 ICASE CCCCC THE FOLLOWING LINE WAS FIXED NOVEMBER 1991 CCCCC BECAUSE THE CALLING ROUTINE (DPYATE) HAD IFLAG NOVEMBER 1991 CCCCC EQUIVALANCED TO IGARBG WHICH WAS INTEGER BUT NOVEMBER 1991 CCCCC DPPHD2 WAS TRYING TO USE IFLAG AS CHARACTER*2 NOVEMBER 1991 CCCCC CHARACTER*2 IFLAG CHARACTER*2 STAR C CCCCC THE FOLLOWING 2 SECTIONS WERE ADDED OCTOBER 1991 CHARACTER*80 IFILE1 CHARACTER*12 ISTAT1 CHARACTER*12 IFORM1 CHARACTER*12 IACCE1 CHARACTER*12 IPROT1 CHARACTER*12 ICURS1 CHARACTER*4 IERRF1 CHARACTER*4 IENDF1 CHARACTER*4 IREWI1 C CHARACTER*4 ISUBN0 C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IERRF2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 C CHARACTER*80 IFILE3 CHARACTER*12 ISTAT3 CHARACTER*12 IFORM3 CHARACTER*12 IACCE3 CHARACTER*12 IPROT3 CHARACTER*12 ICURS3 CHARACTER*4 IERRF3 CHARACTER*4 IENDF3 CHARACTER*4 IREWI3 C CHARACTER*80 IFILE4 CHARACTER*12 ISTAT4 CHARACTER*12 IFORM4 CHARACTER*12 IACCE4 CHARACTER*12 IPROT4 CHARACTER*12 ICURS4 CHARACTER*4 IERRF4 CHARACTER*4 IENDF4 CHARACTER*4 IREWI4 C CCCCC THE FOLLOWING LINE WAS INSERTED NOVEMBER 1989 CHARACTER*4 IYATOS CHARACTER*4 IYATRS C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C CCCCC JUNE, 1990. FOLLOWING INCLUDE FILE NO LONGER NEEDED. CCCCC INCLUDE 'DPCOPA.INC' C CCCCC THE FOLLOWING INCLUDE STATEMENT WAS ADDED OCTOBER 1991 INCLUDE 'DPCOF2.INC' C DIMENSION Y(*) DIMENSION REP(*) C DIMENSION COEF(*) DIMENSION SSQCOE(*) DIMENSION TCOEF(*) DIMENSION RSDCOE(*) DIMENSION TAGCOE(*) DIMENSION TAGCO2(*) C CCCCC FOLLOWING DIMENSIONS MOVED TO DPYATE CCCCC DIMENSION REPD(MAXOBV) CCCCC DIMENSION IFLAG(MAXOBV) CCCCC DIMENSION RSDCOC(MAXOBV) CCCCC DIMENSION ITAG(MAXOBV) CCCCC DIMENSION ITAGCO(MAXOBV) CCCCC DIMENSION YMEAN(MAXOBV) CCCCC DIMENSION YVAR(MAXOBV) CCCCC DIMENSION DUMMY(MAXOBV) CCCCC DIMENSION DUMMY2(MAXOBV) CCCCC DIMENSION AINDEX(MAXOBV) CCCCC DIMENSION AINDE2(MAXOBV) CCCCC DIMENSION TEMP(MAXOBV) DIMENSION REPD(*) DIMENSION IFLAG(*) DIMENSION RSDCOC(*) DIMENSION ITAG(*) DIMENSION ITAGCO(*) DIMENSION YMEAN(*) DIMENSION YVAR(*) DIMENSION DUMMY(*) DIMENSION DUMMY2(*) DIMENSION AINDEX(*) DIMENSION AINDE2(*) DIMENSION TEMP(*) C CCCCC FEBRUARY 1995. SET MAXIMUM FACTORS TO 12 (ALSO DEFINE MAXIMUM CCCCC WITH PARAMETER STATEMENT). CCCCC DIMENSION AMAIN(10) CCCCC DIMENSION PREDLIN(10) CCCCC DIMENSION RESLIN(10) C CCCCC DIMENSION A(10,10) CCCCC DIMENSION EIGVAL(10) CCCCC DIMENSION EIGVA2(10) CCCCC DIMENSION EIGVA3(10) CCCCC DIMENSION EIGVEC(10,10) CCCCC DIMENSION ITAG2(10) CCCCC DIMENSION ITAG3(10) CCCCC DIMENSION PHD1(10) CCCCC DIMENSION PHD2(10) CCCCC DIMENSION PHD3(10) CCCCC DIMENSION PHD4(10) CCCCC DIMENSION PHD5(10) C PARAMETER (MAXFAC=12) C DIMENSION AMAIN(MAXFAC) DIMENSION PREDLIN(MAXFAC) DIMENSION RESLIN(MAXFAC) C DIMENSION A(MAXFAC,MAXFAC) DIMENSION EIGVAL(MAXFAC) DIMENSION EIGVA2(MAXFAC) DIMENSION EIGVA3(MAXFAC) DIMENSION EIGVEC(MAXFAC,MAXFAC) DIMENSION ITAG2(MAXFAC) DIMENSION ITAG3(MAXFAC) DIMENSION PHD1(MAXFAC) DIMENSION PHD2(MAXFAC) DIMENSION PHD3(MAXFAC) DIMENSION PHD4(MAXFAC) DIMENSION PHD5(MAXFAC) DIMENSION VJUNK(2*MAXFAC) 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='DPPH' ISUBN2='D2 ' C CCCCC MAXCOL=10 MAXCOL=MAXFAC C IERROR='NO' C AN=N CUTOFF=999999.0 C CCUTP=YATCCU CCUTN=(-YATCCU) TCUTP=YATTCU TCUTN=(-YATTCU) RCUTP=YATRCU RCUTN=(-YATRCU) C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PHD2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPHD2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,MAXN 53 FORMAT('ICASPL,MAXN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)PRESSD,PRESDF,REPSD,REPDF 55 FORMAT('PRESSD,PRESDF,REPSD,REPDF = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)REFDF,REFDF,SDCOEF 56 FORMAT('REFDF,REFDF,SDCOEF = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)N 60 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO63 DO61I=1,N WRITE(ICOUT,62)I,Y(I),REP(I) 62 FORMAT('I,Y(I),REP(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 61 CONTINUE WRITE(ICOUT,71)YATCCU,YATTCU,YATRCU,IYATOS,IYATRS 71 FORMAT('YATCCU,YATTCU,YATRCU,IYATOS,IYATRS = ',3E15.7, 12X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)CCUTN,CCUTP 72 FORMAT('CCUTN,CCUTP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)TCUTN,TCUTP 73 FORMAT('TCUTN,TCUTP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)RCUTN,RCUTP 74 FORMAT('RCUTN,RCUTP = ',2E15.7) CALL DPWRST('XXX','BUG ') 63 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPPHD2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114)N 1114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1119 CONTINUE C IF(N.GE.2)GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPPHD2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1123) 1123 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1129 CONTINUE C HOLD=Y(1) DO1130I=1,N IF(Y(I).NE.HOLD)GOTO1139 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPPHD2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)HOLD 1133 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1139 CONTINUE C CCCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1995 C ************************************************** C ** STEP 15-- ** C ** OPEN THE STORAGE FILES ** C ************************************************** C 1500 CONTINUE ISTEPN='15' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'YAT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='PHD2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='PHD2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IOUNI3=IST3NU IFILE3=IST3NA ISTAT3=IST3ST IFORM3=IST3FO IACCE3=IST3AC IPROT3=IST3PR ICURS3=IST3CS ISUBN0='PHD2' IERRF3='NO' C IREWI3='ON' CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1IREWI3,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='PHD2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 C C ************************************************** C ** STEP 20-- ** C ** COMPUTE GRAND MEAN ** C ** COMPUTE GRAND STANDARD DEVIATION ** C ************************************************** C SUM=0.0 DO2000I=1,N SUM=SUM+Y(I) 2000 CONTINUE GMEAN=SUM/AN C SUM=0.0 DO2020I=1,N SUM=SUM+(Y(I)-GMEAN)**2 2020 CONTINUE GSSQ=SUM GVAR=GSSQ/(AN-1.0) GSD=0.0 IF(GVAR.GT.0.0)GSD=SQRT(GVAR) C C **************************************************** C ** STEP 21-- ** C ** EXTRACT THE DISTINCT REPLICATION VALUES ** C ** IN ORDER TO ** C ** DETERMINE THE TYPE OF REPLICATION CASE-- ** C ** 1) NO REPLICATION ** C ** 2) REPLICATION 'WITHIN', AS IN ** C ** (FOR A 2**2 WITH 3 REPLICATIONS)-- ** C ** X1 X2 REP ** C ** - + 1 ** C ** - + 2 ** C ** - + 3 ** C ** ** C ** + + 1 ** C ** + + 2 ** C ** + + 3 ** C ** ** C ** - - 1 ** C ** - - 2 ** C ** - - 3 ** C ** ** C ** + + 1 ** C ** + + 2 ** C ** + + 3 ** C ** 3) REPLICATION 'BETWEEN', AS IN ** C ** (FOR A 2**2 WITH 3 REPLICATIONS)-- ** C ** X1 X2 REP ** C ** - + 1 ** C ** + + 1 ** C ** - - 1 ** C ** + + 1 ** C ** ** C ** - + 2 ** C ** + + 2 ** C ** - - 2 ** C ** + + 2 ** C ** ** C ** - + 3 ** C ** + + 3 ** C ** - - 3 ** C ** + + 3 ** C ** ** C **************************************************** C ISTEPN='21' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' CALL DISTIN(REP,N,IWRITE,REPD,NREPD,IBUGA3,IERROR) C NUMREP=NREPD ANUMRE=NUMREP IREP='NO' ICASE='-999' IF(NUMREP.EQ.1)GOTO2190 IREP='YES' ICASE='BETW' IF(REP(2).NE.REP(1))ICASE='WITH' 2190 CONTINUE IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1WRITE(ICOUT,2191)REPD(1),REPD(2),REPD(3),REPD(4) 2191 FORMAT('REPD(1),REPD(2),REPD(3),REPD(4) = ',4E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1CALL DPWRST('XXX','BUG ') IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1WRITE(ICOUT,2192)NREPD,IREP,ICASE 2192 FORMAT('NREPD,IREP,ICASE = ',I8,2X,A4,2X,A4) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1CALL DPWRST('XXX','BUG ') C C ************************************************** C ** STEP 22-- ** C ** COMPUTE CELL MEANS ** C ************************************************** C IF(IREP.EQ.'NO')GOTO2210 IF(ICASE.EQ.'WITH')GOTO2220 GOTO2230 C 2210 CONTINUE NMEAN=N ANMEAN=NMEAN DO2211I=1,N YMEAN(I)=Y(I) 2211 CONTINUE GOTO2290 C 2220 CONTINUE NMEAN=N/NUMREP ANMEAN=NMEAN DO2221I=1,NMEAN SUM=0.0 JMIN=NUMREP*(I-1)+1 JMAX=NUMREP*I DO2222J=JMIN,JMAX SUM=SUM+Y(J) 2222 CONTINUE YMEAN(I)=SUM/ANUMRE 2221 CONTINUE GOTO2290 C 2230 CONTINUE NMEAN=N/NUMREP ANMEAN=NMEAN DO2231I=1,NMEAN SUM=0.0 DO2232J=I,N,NMEAN SUM=SUM+Y(J) 2232 CONTINUE YMEAN(I)=SUM/ANUMRE 2231 CONTINUE GOTO2290 C 2290 CONTINUE NCOEF=NMEAN C C ************************************************** C ** STEP 23-- ** C ** IF HAVE REPLICATION, ** C ** COMPUTE REPLICATION STANDARD DEVIATION ** C ************************************************** C IREPDF=0 REPDF=0.0 REPVAR=0.0 REPSD=0.0 LOFCDF=0.0 IF(IREP.EQ.'NO')GOTO2390 IF(ICASE.EQ.'WITH')GOTO2320 GOTO2330 C 2320 CONTINUE NMEAN=N/NUMREP ANMEAN=NMEAN SUMT=0.0 DO2321I=1,NMEAN SUM=0.0 JMIN=NUMREP*(I-1)+1 JMAX=NUMREP*I DO2322J=JMIN,JMAX SUM=SUM+(Y(J)-YMEAN(I))**2 SUMT=SUMT+(Y(J)-YMEAN(I))**2 2322 CONTINUE YVAR(I)=SUM/(ANUMRE-1.0) 2321 CONTINUE IREPDF=NMEAN REPDF=ANMEAN REPVAR=SUMT/REPDF REPSD=0.0 IF(REPVAR.GT.0.0)REPSD=SQRT(REPVAR) GOTO2390 C 2330 CONTINUE NMEAN=N/NUMREP ANMEAN=NMEAN SUMT=0.0 DO2331I=1,NMEAN SUM=0.0 DO2332J=I,N,NMEAN SUM=SUM+(Y(J)-YMEAN(I))**2 SUMT=SUMT+(Y(J)-YMEAN(I))**2 2332 CONTINUE YVAR(I)=SUM/(ANUMRE-1.0) 2331 CONTINUE IREPDF=NMEAN REPDF=ANMEAN REPVAR=SUMT/REPDF REPSD=0.0 IF(REPVAR.GT.0.0)REPSD=SQRT(REPVAR) GOTO2390 C 2390 CONTINUE NCOEF=NMEAN C C ************************************************** C ** STEP 24-- ** C ** COMPUTE EFFECTS ** C ** (VIA THE YATES ALGORITHM ?) ** C ************************************************** C DO2410I=1,NMEAN COEF(I)=YMEAN(I) 2410 CONTINUE C NPASS=(ALOG10(ANMEAN)/0.30103)+0.5 NUMFAC=NPASS CCCCC FEBRUARY 1995. FOLLOWING SECTION ADDED. IF(NUMFAC.GT.MAXFAC)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2412)MAXFAC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2414)NUMFAC CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 2412 FORMAT('*****ERROR FROM DEX PHD COMMAND. THE MAXIMUM NUMBER ', 1'FACTORS (',I2,') EXCEEDED.') 2414 FORMAT(' DATA SET HAS ',I5,' FACTORS. ') C DO2420IPASS=1,NPASS C DO2430I=1,NMEAN DUMMY(I)=COEF(I) 2430 CONTINUE C J1=0 J2=NMEAN/2 DO2440I=1,NMEAN,2 IP1=I+1 J1=J1+1 J2=J2+1 COEF(J1)=DUMMY(IP1)+DUMMY(I) COEF(J2)=DUMMY(IP1)-DUMMY(I) 2440 CONTINUE C 2420 CONTINUE C COEF(1)=COEF(1)/ANMEAN DO2450I=2,NMEAN COEF(I)=COEF(I)/(ANMEAN/2.0) 2450 CONTINUE C C ************************************************** C ** STEP 24-- ** C ** COMPUTE SUM OF SQUARES FOR EACH EFFECT ** C ** REFERENCE--HUNTER DESIGN OF EXP. COURSE, ** C ** VOLUME 4, PAGE 71 ** C ************************************************** C SSQCOE(1)=GSSQ DO2500I=2,NMEAN SSQCOE(I)=ANMEAN*COEF(I)*COEF(I)/4.0 2500 CONTINUE C C ************************************************** C ** STEP 26-- ** C ** DEFINE IDENTIFIERS ** C ************************************************** C J=0 JP1=1 CCCCC TAGCOE(JP1)=0.0 ITAGCO(JP1)=0.0 C J=1 JP1=2 ITAG(J)=1 CCCCC TAGCOE(JP1)=ITAG(J) ITAGCO(JP1)=ITAG(J) C CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1991 IF(NUMFAC.LE.1)GOTO2629 DO2610IFAC=2,NUMFAC JMIN=2**(IFAC-1) JMAX=(2**IFAC)-1 K=0 DO2620J=JMIN,JMAX JP1=J+1 IF(J.EQ.JMIN)ITAG(J)=IFAC CCCCC IF(J.EQ.JMIN)TAGCOE(JP1)=ITAG(J) IF(J.EQ.JMIN)ITAGCO(JP1)=ITAG(J) IF(J.EQ.JMIN.AND.IFAC.GE.10)ITAGCO(JP1)=ITAGCO(JP1)-10 IF(J.EQ.JMIN)GOTO2620 K=K+1 ITAG(J)=10*ITAG(K)+IFAC CCCCC TAGCOE(JP1)=ITAG(J) ITAGCO(JP1)=ITAG(J) IF(IFAC.GE.10)ITAGCO(JP1)=ITAGCO(JP1)-10 2620 CONTINUE 2610 CONTINUE CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1991 2629 CONTINUE C TAGCO2(1)=0.0 IF(NUMFAC.LE.0)GOTO2639 DO2630I=2,NMEAN AJUNK=ITAGCO(I) CCCCC ATEMP=ALOG10(TAGCOE(I)+0.5) ATEMP=ALOG10(AJUNK+0.5) ATEMP=ATEMP+1.0 ITEMP=ATEMP TAGCO2(I)=ITEMP 2630 CONTINUE 2639 CONTINUE C C ************************************************** C ** STEP 27-- ** C ** COMPUTE PSEUDO-REPLIC. STANDARD DEVIATION ** C ************************************************** C SUM=0.0 SUMI=0.0 DO2700I=1,NMEAN IF(TAGCO2(I).GE.2.5)SUM=SUM+SSQCOE(I) IF(TAGCO2(I).GE.2.5)SUMI=SUMI+1.0 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1WRITE(ICOUT,2701)I,TAGCO2(I),COEF(I),SSQCOE(I),SUMI,SUM 2701 FORMAT('I,TAGCO2(I),COEF(I),SSQCOE(I),SUMI,SUM = ',I8,5E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1CALL DPWRST('XXX','BUG ') 2700 CONTINUE PRESSS=SUM PRESDF=SUMI IPRESD=PRESDF+0.5 PRESVA=0.0 IF(PRESDF.GT.0.1)PRESVA=PRESSS/PRESDF PRESSD=0.0 IF(PRESVA.GT.0.0)PRESSD=SQRT(PRESVA) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1WRITE(ICOUT,2702)PRESSS,PRESVA,PRESDF,PRESSD 2702 FORMAT('PRESSS,PRESVA,PRESDF,PRESSD = ',4E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1CALL DPWRST('XXX','BUG ') C C **************************************************************** C ** STEP 28-- * C ** COMPUTE A REFERENCE STANDARD DEVIATION * C ** WHICH EQUALS * C ** THE REPLICATION ST. DEV. (IF HAVE REPLICATION) * C ** THE PSEUDO-REPLIC. ST. DEV. (IF NOT HAVE REPLICATION) * C **************************************************************** C IREFDF=0 IF(IREP.EQ.'NO')IREFDF=IPRESD IF(IREP.EQ.'YES')IREFDF=IREPDF C REFVAR=0.0 IF(IREP.EQ.'NO')REFVAR=PRESVA C IF(IREP.EQ.'YES')REFVAR=REPVAR REFSD=0.0 IF(REFVAR.GT.0.0)REFSD=SQRT(REFVAR) C C ************************************************** C ** STEP 29-- ** C ** COMPUTE STANDARD DEV. FOR EACH COEF ** C ** REFERENCE--HUNTER DESIGN OF EXP. COURSE, ** C ** VOLUME 4, PAGE 82 ** C ************************************************** C VCOER=0.0 VCOER=2.0*(REPVAR/(AN/2.0)) SDCOER=0.0 IF(VCOER.GT.0.0)SDCOER=SQRT(VCOER) C VCOEP=0.0 VCOEP=2.0*(PRESVA/(AN/2.0)) SDCOEP=0.0 IF(VCOEP.GT.0.0)SDCOEP=SQRT(VCOEP) C VCOEF=0.0 VCOEF=2.0*(REFVAR/(AN/2.0)) SDCOEF=0.0 IF(VCOEF.GT.0.0)SDCOEF=SQRT(VCOEF) C CCCCC THE FOLLOWING 4 LINES WERE ADDED OCTOBER 1991 VGMEAN=0.0 VGMEAN=REFVAR/AN SDGMEA=0.0 IF(VGMEAN.GT.0.0)SDGMEA=SQRT(VGMEAN) C IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1WRITE(ICOUT,2903)REFVAR,REFSD,VCOEF,SDCOEF 2903 FORMAT('REFVAR,REFSD,VCOEF,SDCOEF = ',4E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PHD2') 1CALL DPWRST('XXX','BUG ') C C ************************************************** C ** STEP 30-- ** C ** COMPUTE T VALUE FOR EACH COEF ** C ************************************************** C DO3010I=1,NMEAN TCOEF(I)=0.0 IF(SDCOEF.GT.0.0)TCOEF(I)=COEF(I)/SDCOEF IF(SDCOEF.GT.0.0.AND.TCOEF(I).GT.CUTOFF)TCOEF(I)=CUTOFF IF(SDCOEF.GT.0.0.AND.TCOEF(I).LT.-CUTOFF)TCOEF(I)=(-CUTOFF) 3010 CONTINUE C C ************************************************** C ** STEP 31-- ** C ** COMPUTE A SORT INDEX BASED ON ** C ** THE MAGNITUDE OF THE EFFECTS ** C ************************************************** C DO3110I=1,NMEAN DUMMY(I)=(-ABS(COEF(I))) AINDEX(I)=I 3110 CONTINUE C AMIN=DUMMY(1) DO3120I=1,NMEAN IF(DUMMY(I).LT.AMIN)AMIN=DUMMY(I) 3120 CONTINUE DUMMY(1)=AMIN-10.0 C CALL SORTC(DUMMY,AINDEX,NMEAN,DUMMY2,AINDE2) C C ************************************************** C ** STEP 32-- ** C ** COMPUTE THE RESIDUAL STANDARD DEVIATION ** C ** THAT WOULD RESULT IF FIT EACH TERM ** C ** INDIVIDUALLY, AS IN ** C ** RESPONSE = CONSTANT + TERM + ERROR ** C ************************************************** C CCCCC DO3210I=1,NMEAN CCCCC CALL DMV(TAGCOE(I),NMEAN,TEMP) CCCCC COEFFI=COEF(I) CCCCC SUM=0.0 CCCCC DO3220J=1,NMEAN CCCCC PREDJ=GMEAN+COEFFI*TEMP(J) CCCCC RESJ=Y(J)-PREDJ CCCCC SUM=SUM+RESJ*RESJ C3220 CONTINUE CCCCC RESVI=SUM/(AN-2.0) CCCCC RESSDI=0.0 CCCCC IF(RESVI.GT.0.0)RESSDI=SQRT(RESVI) CCCCC RSDCOE(I)=RESSDI C3210 CONTINUE C DO3210I=1,NMEAN CCCCC THE FOLLOWING LINE WAS INSERTED JUNE 1992 (JJF) RVAR=0.0 CCCCC IF(I.EQ.1)RVAR=SSQCOE(1)/(ANMEAN-1.0) IF(I.EQ.1)RVAR=SSQCOE(1)/(AN-1.0) CCCCC IF(I.GE.2)RVAR=(SSQCOE(1)-SSQCOE(I))/(ANMEAN-1.0-1.0) CCCCC THE FOLLOWING LINE WAS FIXED NOVEMBER 1991 CCCCC IF(I.GE.2)RVAR=(SSQCOE(1)-SSQCOE(I))/(AN-1.0-1.0) IDENOM=N-1-1 CCCCC THE FOLLOWING LINE WAS COMMENTED OUT & MOVED UP JUNE 1992 (JJF) CCCCC RVAR=0.0 IF(I.GE.2.AND.IDENOM.GE.1)RVAR=(SSQCOE(1)-SSQCOE(I))/ 1(AN-1.0-1.0) RSDCOE(I)=0.0 IF(RVAR.GT.0.0)RSDCOE(I)=SQRT(RVAR) 3210 CONTINUE C DO3220I=1,NMEAN AI=I I2=AINDE2(I)+0.5 IF(I.EQ.1)CUMSSQ=0.0 IF(I.GE.2)CUMSSQ=CUMSSQ+SSQCOE(I2) CCCCC IF(I.LT.NMEAN)RVAR=(SSQCOE(1)-CUMSSQ)/(ANMEAN-AI) IF(I.LT.NMEAN)RVAR=(SSQCOE(1)-CUMSSQ)/(AN-AI) IF(I.EQ.NMEAN.AND.IREP.EQ.'YES')RVAR=(SSQCOE(1)-CUMSSQ)/(AN-AI) IF(I.EQ.NMEAN.AND.IREP.EQ.'NO')RVAR=0.0 RSDCOC(I2)=0.0 IF(RVAR.GT.0.0)RSDCOC(I2)=SQRT(RVAR) 3220 CONTINUE C C ************************************************** C ** STEP 33-- ** C ** COMPUTE 97.5 AND 99.5 PERCENT POINTS ** C ** COMPUTE 95% AND 99% CONFIDENCE LIMITS ** C ************************************************** C NU=IREFDF C P=0.975 CALL TPPF(P,REAL(NU),T975) CL95=T975*SDCOEF C P=0.995 CALL TPPF(P,REAL(NU),T995) CL99=T995*SDCOEF C C ************************************************** C ** STEP 34-- ** C ** FLAG THOSE EFFECTS WHICH HAVE T VALUES ** C ** LARGER (IN MAGNITUDE) THAT T975, AND ** C ** LARGER (IN MAGNITUDE) THAT T995 ** C ************************************************** C DO3400I=1,NMEAN CCCCC THE FOLLOWING 3 LINES WERE FIXED NOVEMBER 1991 CCCCC IFLAG(I)=' ' CCCCC IF(ABS(TCOEF(I)).GT.T975)IFLAG(I)='* ' CCCCC IF(ABS(TCOEF(I)).GT.T995)IFLAG(I)='**' IFLAG(I)=0 IF(ABS(TCOEF(I)).GT.T975)IFLAG(I)=1 IF(ABS(TCOEF(I)).GT.T995)IFLAG(I)=2 3400 CONTINUE C C **************************** C ** STEP 71-- ** C ** WRITE EVERYTHING OUT ** C **************************** C ISTEPN='71' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO7690 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7101) 7101 FORMAT(' *****************************') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7102) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING LINE WAS REWORDED JUNE 1989 7102 FORMAT(' ** 2**K DEX FIT ** ') WRITE(ICOUT,7101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED JUNE 1989 WRITE(ICOUT,7112) 7112 FORMAT(' (NOTE--DATA MUST BE IN STANDARD ORDER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7113)N 7113 FORMAT(' NUMBER OF OBSERVATIONS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7114)NUMFAC 7114 FORMAT(' NUMBER OF FACTORS = ',I8) CALL DPWRST('XXX','BUG ') IF(IREP.EQ.'NO')WRITE(ICOUT,7115) 7115 FORMAT(' NO REPLICATION CASE') IF(IREP.EQ.'NO')CALL DPWRST('XXX','BUG ') IF(IREP.EQ.'YES')WRITE(ICOUT,7116) 7116 FORMAT(' REPLICATION CASE') IF(IREP.EQ.'YES')CALL DPWRST('XXX','BUG ') C IF(IYATOS.EQ.'1'.OR.IYATOS.EQ.'12'.OR.IYATOS.EQ.'13'.OR. 1IYATOS.EQ.'123')GOTO7120 GOTO7290 7120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 4 LINES WERE COMMENTED OUT NOVEMBER 1991 CCCCC WRITE(ICOUT,7121)RESSD C7121 FORMAT(' RESIDUAL STANDARD DEVIATION = ',E20.11) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7122)IRESDF C7122 FORMAT(' RESIDUAL DEGREES OF FREEDOM = ',I8) CCCCC CALL DPWRST('XXX','BUG ') IF(IREP.EQ.'YES')WRITE(ICOUT,7123)REPSD 7123 FORMAT(' REPLICATION STANDARD DEVIATION = ',E20.11) IF(IREP.EQ.'YES')CALL DPWRST('XXX','BUG ') IF(IREP.EQ.'YES')WRITE(ICOUT,7124)IREPDF 7124 FORMAT(' REPLICATION DEGREES OF FREEDOM = ',I8) IF(IREP.EQ.'YES')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7125)PRESSD 7125 FORMAT(' PSEUDO-REPLICATION STAND. DEV. = ',E20.11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7126)IPRESD 7126 FORMAT(' PSEUDO-DEGREES OF FREEDOM = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7127) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING LINE WAS REWORDED JUNE 1989 7127 FORMAT(' (THE PSEUDO-REP. STAND. DEV. ASSUMES ALL') WRITE(ICOUT,7128) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING LINE WAS REWORDED JUNE 1989 7128 FORMAT(' 3, 4, 5, ...-TERM INTERACTIONS ARE NOT REAL,') CCCCC THE FOLLOWING 2 LINES WERE ADDED JUNE 1989 WRITE(ICOUT,7129) 7129 FORMAT(' BUT MANIFESTATIONS OF RANDOM ERROR)') CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IF(IREP.EQ.'YES') 1WRITE(ICOUT,7131)SDCOER 7131 FORMAT(' STANDARD DEVIATION OF A COEF. = ',E20.11) IF(IREP.EQ.'YES') 1CALL DPWRST('XXX','BUG ') IF(IREP.EQ.'YES') 1WRITE(ICOUT,7132) 7132 FORMAT(' (BASED ON REPLICATION ST. DEV.)') IF(IREP.EQ.'YES') 1CALL DPWRST('XXX','BUG ') IF(IREP.EQ.'NO') 1WRITE(ICOUT,7133)SDCOEP 7133 FORMAT(' STANDARD DEVIATION OF A COEF. = ',E20.11) IF(IREP.EQ.'NO') 1CALL DPWRST('XXX','BUG ') IF(IREP.EQ.'NO') 1WRITE(ICOUT,7134) 7134 FORMAT(' (BASED ON PSEUDO-REP. ST. DEV.)') IF(IREP.EQ.'NO') 1CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7211)GMEAN 7211 FORMAT(' GRAND MEAN = ',E20.11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7212)GSD 7212 FORMAT(' GRAND STANDARD DEVIATION = ',E20.11) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7224)CL99 7224 FORMAT(' 99% CONFIDENCE LIMITS (+-) = ',E20.11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7223)CL95 7223 FORMAT(' 95% CONFIDENCE LIMITS (+-) = ',E20.11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7222)T995 7222 FORMAT(' 99.5% POINT OF T DISTRIBUTION = ',E20.11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7221)T975 7221 FORMAT(' 97.5% POINT OF T DISTRIBUTION = ',E20.11) CALL DPWRST('XXX','BUG ') C 7290 CONTINUE C IF(IYATOS.EQ.'3'.OR.IYATOS.EQ.'13'.OR.IYATOS.EQ.'23'.OR. 1IYATOS.EQ.'123')GOTO7400 GOTO7490 C 7400 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7411) 7411 FORMAT(' IDENTIFIER EFFECT ', 1' T VALUE RESSD RESSD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7412) 7412 FORMAT(37X,2X, 1' MEAN+TERM MEAN+TERMS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7413) 7413 FORMAT('-----------------------------------------------', 1'------------------------------') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7431)GMEAN,RSDCOE(1),RSDCOE(1) 7431 FORMAT(11X,' MEAN',F14.5,13X,2X,F11.5,F11.5) CALL DPWRST('XXX','BUG ') C ITAGCO(1)=0 TCOEF(1)=-999.99 IF(SDGMEA.GT.0.0)TCOEF(1)=GMEAN/SDGMEA IFLAG(1)=0 C DO7440I=2,NMEAN I2=AINDE2(I)+0.5 IF(CCUTP.GE.CPUMAX.AND. 1 TCUTP.GE.CPUMAX.AND. 1 RCUTP.GE.CPUMAX)GOTO7441 IF(CCUTP.LT.CPUMAX.AND. 1CCUTN.LE.COEF(I2).AND.COEF(I2).LE.CCUTP)GOTO7440 IF(TCUTP.LT.CPUMAX.AND. 1TCUTN.LE.TCOEF(I2).AND.TCOEF(I2).LE.TCUTP)GOTO7440 IF(RCUTP.LT.CPUMAX.AND. 1RCUTN.LE.RSDCOC(I2).AND.RSDCOC(I2).LE.RCUTP)GOTO7440 7441 CONTINUE STAR=' ' IF(IFLAG(I2).EQ.1)STAR='* ' IF(IFLAG(I2).EQ.2)STAR='**' WRITE(ICOUT,7442)ITAGCO(I2),COEF(I2),TCOEF(I2),STAR, 1RSDCOE(I2),RSDCOC(I2) 7442 FORMAT(15X,I11,F14.5,F13.1,A2,F11.5,F11.5) CALL DPWRST('XXX','BUG ') 7440 CONTINUE 7490 CONTINUE C 7690 CONTINUE C CCCCC FEBRUARY 1995. COMMENT OUT FOLLOWING MESSAGE SINCE CCCCC DON'T CURRENTLY ACTUALLY DO THIS. CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7711) C7711 FORMAT('NOTE--TAG, COEF, TCOEF, RESSD, & CUMULATIVE RESSD') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7712) C7712 FORMAT(' WRITTEN TO FILES DPST1F.DAT AND DPST2F.DAT') CCCCC CALL DPWRST('XXX','BUG ') C C FORM VECTOR OF ESTIMATED MAIN EFFECTS. C IMAX=2**NUMFAC DO8100I=1,IMAX IVALUE=ITAGCO(I) IF(0.LE.IVALUE.AND.IVALUE.LE.9)THEN IUNITS=IVALUE IF(IUNITS.LE.0)IUNITS=10 AMAIN(IUNITS)=COEF(I) ENDIF 8100 CONTINUE C C FORM PREDICTED VALUES AND RESIDUALS FOR MAIN EFFECTS MODEL C DO8110I=1,N SUM=0.0 DO8120J=1,NUMFAC CALL YATES(I,J,XIJ) SUM=SUM+AMAIN(J)*XIJ 8120 CONTINUE SUM=0.5*SUM SUM=SUM+GMEAN PREDLIN(I)=SUM RESLIN(I)=Y(I)-PREDLIN(I) 8110 CONTINUE C C FORM THE MATRIX OF 2-TERM INTERACTION EFFECTS C DO8200I=1,NUMFAC A(I,I)=0.0 8200 CONTINUE C IMAX=2**NUMFAC DO8210I=1,IMAX IVALUE=ITAGCO(I) IF(10.LE.IVALUE.AND.IVALUE.LE.99)THEN ITENS=IVALUE/10 ITERM=10*ITENS IUNITS=IVALUE-ITERM IF(ITENS.LE.0)ITENS=10 IF(IUNITS.LE.0)IUNITS=10 A(ITENS,IUNITS)=COEF(I) A(IUNITS,ITENS)=COEF(I) ENDIF 8210 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IMAX=2**NUMFAC DO8250I=1,IMAX CCCCC FEBRUARY 1995. CONVERT TO STANDARD DATAPLOT I/O CCCCC WRITE(6,8255)I,ITAGCO(I),COEF(I) WRITE(ICOUT,8255)I,ITAGCO(I),COEF(I) 8255 FORMAT(1H ,'I,ITAGCO(I),COEF(I) = ',2I8,F10.3) CALL DPWRST('XXX','BUG ') 8250 CONTINUE C DO8300I=1,NUMFAC CCCCC FEBRUARY 1995. CONVERT TO STANDARD DATAPLOT I/O CCCCC FEBRUARY 1995. WRITE TO DPST1F.DAT AW WELL CCCCC WRITE(6,8305)(A(I,J),J=1,NUMFAC) WRITE(ICOUT,8305)(A(I,J),J=1,NUMFAC) 8305 FORMAT(1H ,10F10.3) CALL DPWRST('XXX','BUG ') WRITE(IOUNI1,8306)(A(I,J),J=1,NUMFAC) 8306 FORMAT(12(1X,E15.7)) 8300 CONTINUE C C DETERMINE THE EIGENVALUES AND EIGENVECTORS OF THE MATRIX C CCCCC AUGUST 1995. REPLACE NUMERICAL RECIPES ROUTINE WITH CCCCC EISPACK ROUTINE. SSIEV IS FOR SYMMETRIC CASE. CCCCC CALL JACOBI(A,NUMFAC,MAXCOL,EIGVAL,EIGVEC,JACROT) IERR2=0 IJOB=1 DO8341JJ=1,MAXFAC DO8342II=1,MAXFAC EIGVEC(II,JJ)=A(II,JJ) 8342 CONTINUE 8341 CONTINUE CALL SSIEV(EIGVEC,MAXCOL,NUMFAC,EIGVAL,VJUNK,IJOB,IERR2) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC FEBRUARY 1995. CONVERT TO STANDARD DATAPLOT I/O DO8410I=1,NUMFAC CCCCC WRITE(6,8411)EIGVAL(I) WRITE(ICOUT,8411)EIGVAL(I) 8411 FORMAT(1H ,10F10.3) CALL DPWRST('XXX','BUG ') 8410 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC FEBRUARY 1995. CONVERT TO STANDARD DATAPLOT I/O DO8510I=1,NUMFAC CCCCC WRITE(6,8511)(EIGVEC(I,J),J=1,NUMFAC) WRITE(ICOUT,8511)(EIGVEC(I,J),J=1,NUMFAC) 8511 FORMAT(1H ,10F10.3) CALL DPWRST('XXX','BUG ') WRITE(IOUNI3,8512)(EIGVEC(I,J),J=1,NUMFAC) 8512 FORMAT(12(1X,E15.7)) 8510 CONTINUE C C DETERMINE THE 2 LARGEST (IN MAGNITUDE) EIGENVALUES C AND WHAT EIGENVECTORS THEY ARE ASSOCIATED WITH C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO8600I=1,NUMFAC EIGVA2(I)=ABS(EIGVAL(I)) EIGVA2(I)=(-EIGVA2(I)) ITAG2(I)=I 8600 CONTINUE C CALL SORTC(EIGVA2,ITAG2,NUMFAC,EIGVA3,ITAG3) C DO8610I=1,NUMFAC EIGVA2(I)=(-EIGVA2(I)) EIGVA3(I)=(-EIGVA3(I)) 8610 CONTINUE C C COMPUTE PHD'S C INDEX1=ITAG3(1) INDEX2=ITAG3(2) INDEX3=ITAG3(3) INDEX4=ITAG3(4) CCCCC APRIL 1996. CHANGE FOLLOWING LINE CCCCC INDEX4=ITAG3(5) INDEX5=ITAG3(5) DO8710I=1,N SUM1=0.0 SUM2=0.0 SUM3=0.0 SUM4=0.0 SUM5=0.0 DO8720J=1,NUMFAC CALL YATES(I,J,XIJ) SUM1=SUM1+XIJ*EIGVEC(J,INDEX1) SUM2=SUM2+XIJ*EIGVEC(J,INDEX2) SUM3=SUM3+XIJ*EIGVEC(J,INDEX3) SUM4=SUM4+XIJ*EIGVEC(J,INDEX4) SUM5=SUM5+XIJ*EIGVEC(J,INDEX5) 8720 CONTINUE PHD1(I)=SUM1 PHD2(I)=SUM2 PHD3(I)=SUM3 PHD4(I)=SUM4 PHD5(I)=SUM5 8710 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC FEBRUARY 1995. PRINT EIGENVALIES (UNORDERED AND ORDERED) TO CCCCC FILE DPST2F.DAT DO8800I=1,NUMFAC CCCCC WRITE(IPR,8810)I,ITAG3(I),EIGVA3(I) WRITE(ICOUT,8810)I,ITAG3(I),EIGVA3(I) 8810 FORMAT(1H ,'I,ITAG3(I),EIGVA3(I) = ',I8,I8,F10.3) CALL DPWRST('XXX','BUG ') WRITE(IOUNI2,8811)EIGVAL(I),ITAG3(I),EIGVAL(ITAG3(I)) 8811 FORMAT(1X,E15.7,1X,I5,1X,E15.7) 8800 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO8820I=1,N CCCCC WRITE(IPR,8830)I,Y(I),PREDLIN(I),RESLIN(I),PHD1(I),PHD2(I) WRITE(ICOUT,8830)I,Y(I),PREDLIN(I),RESLIN(I),PHD1(I),PHD2(I) 8830 FORMAT(1H ,'I,Y(I),PREDLIN(I),RESLIN(I),PHD1(I),PHD2(I) = ', 1I8,5F10.3) CALL DPWRST('XXX','BUG ') 8820 CONTINUE CCCCC FEBRUARY 1995. PRINT PRED, RES, AND FIRST 5 PHD EIGENVECTORS CCCCC TO FILE DPST4F.DAT DO8860I=1,N WRITE(IOUNI4,8870)PREDLIN(I),RESLIN(I),PHD1(I),PHD2(I), &PHD3(I),PHD4(I),PHD5(I) 8870 FORMAT(7(1X,E15.7)) CALL DPWRST('XXX','BUG ') 8860 CONTINUE C CCCCC THE FOLLOWING WAS ADDED FEBRUARY 1995 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8891) 8891 FORMAT('NOTE--THE MATRIX OF 2-TERM INTERACTIONS WRITTEN TO ', &'FILE DPST1F.DAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8892) 8892 FORMAT(' --THE EIGENVALUES OF THE MATRIX WRITTEN TO ', &'FILE DPST3F.DAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8893) 8893 FORMAT(' --THE EIGENVECTORS OF THE MATRIX WRITTEN TO ', &'FILE DPST3F.DAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8894) 8894 FORMAT(' --THE PREDICTED, VALUES, RESIDUALS, AND FIRST 5 ', &'PHD VECOTRS WRITTEN TO FILE DPST4F.DAT') CALL DPWRST('XXX','BUG ') C CCCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1995 C ************************************** C ** STEP 89-- ** C ** CLOSE THE STORAGE FILES. ** C ************************************** C 8900 CONTINUE C ISTEPN='89' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'YAT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IENDF3='OFF' IREWI3='ON' CALL DPCLFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1IENDF3,IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1IENDF4,IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PHD2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPHD2--') CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE FIXED APRIL 1992 CCCCC WRITE(ICOUT,9012)IFOUND,IERROR C9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMREP,IREP,ICASE 9013 FORMAT('N,NUMREP,IREP,ICASE = ',2I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)GMEAN,GSSQ,GVAR,GSD 9014 FORMAT('GMEAN,GSSQ,GVAR,GSD = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PRESSD,PRESDF,REPSD,REPDF 9015 FORMAT('PRESSD,PRESDF,REPSD,REPDF = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)REFDF,REFDF,SDCOEF 9016 FORMAT('REFDF,REFDF,SDCOEF = ',3E15.7) CALL DPWRST('XXX','BUG ') DO9021I=1,NMEAN WRITE(ICOUT,9022)I,YMEAN(I),COEF(I),YVAR(I) 9022 FORMAT('I,YMEAN(I),COEF(I),YVAR(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9021 CONTINUE WRITE(ICOUT,9031)YATCCU,YATTCU,YATRCU,IYATOS,IYATRS 9031 FORMAT('YATCCU,YATTCU,YATRCU,IYATOS,IYATRS = ',3E15.7, 12X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)CCUTN,CCUTP 9032 FORMAT('CCUTN,CCUTP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)TCUTN,TCUTP 9033 FORMAT('TCUTN,TCUTP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)RCUTN,RCUTP 9034 FORMAT('RCUTN,RCUTP = ',2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPIE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1CLLIMI,CLWIDT,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE THE FOLLOWING PLOT-- C A PIE CHART; 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 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --OCTOBER 1978. C UPDATED --APRIL 1979. C UPDATED --JANUARY 1981. C UPDATED --OCTOBER 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --NOVEMBER 1993. ADDITIONAL ARRAY FOR DPPIE2 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 IDATSW CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION CLLIMI(*) DIMENSION CLWIDT(*) C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) CCCCC NOVEMBER 1993. ADD FOLLOWING LINE (AND ADD EQUIVALENCE) DIMENSION YTEMP(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) EQUIVALENCE (GARBAG(IGARB3),YTEMP(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPPI' ISUBN2='E ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=2 C ICOLR=0 C C *************************** C ** TREAT THE PIE CHART ** C *************************** C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPIE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'PIE'.AND.IHARG(1).EQ.'CHAR')GOTO110 C IFOUND='NO' GOTO9000 C 110 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' ICASPL='PIEC' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,IHLEF2,ICOLL,NLEFT 211 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPPIE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A PIE CHART ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPPIE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ****************************************************** C ** STEP 5-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE NOT DATA POINTS ** C ** BUT ALREADY-COMPUTED FREQUENCIES, ** C ** AND THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE CORRESPONDING X VALUES FOR EACH ** C ** FREQUENCY. IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ****************************************************** C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IDATSW='RAW' IF(NUMV2.EQ.1)IDATSW='RAW' IF(NUMV2.EQ.1)GOTO590 IF(NUMV2.EQ.2)IDATSW='FREQ' IF(NUMV2.EQ.2)GOTO509 GOTO550 C 509 CONTINUE IHRIGH=IHARG(2) IHRIG2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,511)IHRIGH,IHRIG2,ICOLR,NRIGHT 511 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NRIGHT.NE.NLEFT)GOTO570 GOTO590 C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPPIE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A PIE CHART, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) 559 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 560 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562)NUMV2 562 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,563) 563 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,564)(IANS(I),I=1,IWIDTH) 564 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPPIE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A PIE CHART, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578) 578 FORMAT(' WHEN HAVE 2 VARIABLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,580) 580 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' THE FIRST VARIABLE (FREQUENCIES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584)IHLEFT,IHLEF2,NLEFT 584 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE SECOND VARIABLE (HORIZ. AXIS VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586)IHRIGH,IHRIG2,NRIGHT 586 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH) 588 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ***************************************** C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ** AND CARRY OUT THE PLOTS. ** C ***************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 C IF(NUMV2.LE.1)GOTO651 GOTO652 C 651 CONTINUE IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)X1(J)=TAGPLO(I) GOTO660 C 652 CONTINUE IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLR.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)X1(J)=TAGPLO(I) IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) GOTO660 C 660 CONTINUE NLOCAL=J C C **************************************************************** C ** STEP 7-- C ** DETERMINE IF THE ANALYST C ** HAS SPECIFIED 1) THE CLASS WIDTH, C ** 2) THE MIN POINT OF THE FIRST CELL, C ** 3) THE MAX POINT OF THE LAST CELL, C ** FOR THE DISTRIBUTIONAL ANALYSIS. C ** IF NON-DEFAULT, USE THE SPECIFIED VALUES. C ** IF DEFAULT, USE THE DEFAULT VALUES-- C ** 1) CLASS WIDTH = .3 OF A SAMPLE STANDARD DEVIATION; C ** 2) START = SAMPLE MEAN - 6*(SAMPLE STANDARD DEVIATION); C ** 3) STOP = SAMPLE MEAN + 6*(SAMPLE STANDARD DEVIATION); C ** NOTE THAT THE DEFAULT SETTINGS ARE IN FACT C **************************************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CLWID=CLWIDT(1) XSTART=CLLIMI(1) XSTOP=CLLIMI(2) C C ***************************************************** C ** STEP 8-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C CALL DPPIE2(Y1,X1,NLOCAL,IDATSW,CLWID,XSTART,XSTOP, CCCCC NOVEMBER 1993. ADD FOLLOWING LINE 1YTEMP, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPIE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)CLWID,XSTART,XSTOP 9014 FORMAT('CLWID,XSTART,XSTOP = ',3E15.7) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9090 DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPIE2(Y,X,N,IDATSW,CLWID,XSTART,XSTOP, CCCCC NOVEMBER 1993. ADD FOLLOWING LINE 1YTEMP, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C A PIE CHART 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 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --OCTOBER 1978. C UPDATED --MARCH 1979. C UPDATED --APRIL 1979. C UPDATED --JANUARY 1981. C UPDATED --AUGUST 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --NOVEMBER 1993. EACH SLICE HAS SAME TAG TO C ALLOW ATTRIBUTE SETTING (ALAN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IDATSW CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) CCCCC NOVEMBER 1993. ADD FOLLOWING LINE DIMENSION YTEMP(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.1415926535878/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPPI' ISUBN2='E2 ' C IERROR='NO' C KP1=0 NWITHI=0 JWITHI=0 C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPPIE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(N.GE.2)GOTO49 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN DPPIE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47) 47 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48) 48 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 49 CONTINUE C HOLD=X(1) DO60I=1,N IF(X(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPPIE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL INPUT HORIZONTAL AXIS ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO80 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPPIE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IDATSW 71 FORMAT('IDATSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP 72 FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y(I),X(I) 74 FORMAT('I, Y(I), X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE 80 CONTINUE C C ********************************************** C ** STEP 2-- ** C ** IF NECESSARY, ** C ** DETERMINE CLASS WIDTH, ** C ** START VALUE, STOP VALUE, ** C ** AND NUMBER OF CLASSES. ** C ********************************************** C IF(IDATSW.EQ.'RAW')GOTO110 IF(IDATSW.EQ.'FREQ')GOTO150 C 110 CONTINUE IF(CLWID.NE.CPUMIN.AND.XSTART.NE.CPUMIN.AND. 1XSTOP.NE.CPUMAX)GOTO119 IWRIT2='OFF' CALL MEAN(X,N,IWRIT2,XMEAN,IBUGG3,IERROR) CALL SD(X,N,IWRIT2,XSD,IBUGG3,IERROR) IF(CLWID.EQ.CPUMIN)CLWID=0.3*XSD IF(XSTART.EQ.CPUMIN)XSTART=XMEAN-6.0*XSD IF(XSTOP.EQ.CPUMAX)XSTOP=XMEAN+6.0*XSD 119 CONTINUE GOTO180 C 150 CONTINUE CALL SORT(X,N,D2) NM1=N-1 CLWID=D2(2)-D2(1) DO160I=1,NM1 IP1=I+1 DELI=D2(IP1)-D2(I) IF(DELI.LT.CLWID)CLWID=DELI 160 CONTINUE XSTART=D2(1)-(CLWID/2.0) XSTOP=D2(N)+(CLWID/2.0) GOTO180 C 180 CONTINUE TOTWID=XSTOP-XSTART ANUMCL=TOTWID/CLWID NUMCLA=ANUMCL+1.0 C J=NUMCLA-1 AJ=J CLMAXJ=XSTART+AJ*CLWID ABSDEL=ABS(CLMAXJ-XSTOP) IF(ABSDEL.LE.0.0001)NUMCLA=NUMCLA-1 C C ******************************************************* C ** STEP 3-- ** C ** DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS ** C ******************************************************* C DO300J=1,NUMCLA D2(J)=0.0 300 CONTINUE C IF(IDATSW.EQ.'RAW')GOTO410 IF(IDATSW.EQ.'FREQ')GOTO510 C 410 CONTINUE DO420I=1,N DO430J=1,NUMCLA J2=J AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)GOTO440 430 CONTINUE GOTO420 440 CONTINUE D2(J2)=D2(J2)+1.0 420 CONTINUE C C FOR THIS RAW DATA CASE, C TREAT THE SPECIAL CASE OF EQUALITY C WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS C J=NUMCLA DO450I=1,N AJ=J CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(X(I).EQ.CLMAXJ)D2(J)=D2(J)+1.0 450 CONTINUE GOTO590 C 510 CONTINUE DO520I=1,N DO530J=1,NUMCLA J2=J AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)GOTO540 530 CONTINUE GOTO520 540 CONTINUE D2(J2)=D2(J2)+Y(I) 520 CONTINUE C C FOR THIS FREQUENCY DATA CASE, C TREAT THE SPECIAL CASE OF EQUALITY C WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS C (ALTHOUGH THIS SHOULD NOT HAPPEN WITH THE IDATSW = 'FREQ' CASE.) C J=NUMCLA DO550I=1,N AJ=J CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(X(I).EQ.CLMAXJ)D2(J)=D2(J)+Y(I) 550 CONTINUE GOTO590 C 590 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO595 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,591) 591 FORMAT('***** IN THE MIDDLE OF DPPIE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,592)CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA 592 FORMAT('CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA= ',5E11.4,I8) CALL DPWRST('XXX','BUG ') DO593J=1,NUMCLA AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP FJ=D2(J) WRITE(ICOUT,594)J,CLMINJ,CLMAXJ,FJ 594 FORMAT('J,CLMINJ,CLMAXJ,FJ = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 593 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 595 CONTINUE C C ********************************** C ** STEP 4-- ** C ** DETERMINE PLOT COORDINATES ** C ********************************** C 1100 CONTINUE SUM=0.0 DO1110J=1,NUMCLA SUM=SUM+D2(J) 1110 CONTINUE AN2=SUM C CCCCC NOVEMBER, 1993. FOLLOWING SECTION MODIFIED TO MAKE PIE SEGMENTS CCCCC HAVE A COMMON "TAG". THIS WILL ALLOW REGION ATTRIBUTES TO BE CCCCC SET (E.G., FILL, COLOR, FILL PATTERN) INDIVIDUALLY FOR EACH PIE CCCCC SLICE (PREVIOUSLY, SETTING REGION ATTRIBUTES CAUSED VERY CCCCC STRANGE AND UNDESIRABLE RESULTS). SUM=0.0 DO1115J=1,NUMCLA FJ=D2(J) SUM=SUM+FJ CUMFJ=SUM FRACT=CUMFJ/AN2 YTEMP(J)=FRACT 1115 CONTINUE CCCCC JANUARY 1998. ON SOME PLATFORMS, THE FOLLOWING: CCCCC LET Y = DATA 2 8 10 CCCCC LET X = DATA 1 2 3 CCCCCC PIE CHART Y X CCCCCC CAUSES A PROBLEM. IN THIS CASE, THE BOTTOM HALF OF THE CCCCCC PIE CHART IS A SINGLE SEMI-CIRCLE (I.E., 50% OF DATA), CCCCCC ALGORITHM BELOW RECOGNIZED RADOLD AS EQUAL TO RAD2. BASE CCCCCC COMPARISON BELOW (WHICH IS USED TO SKIP EMPTY SLICES) ON CCCCC VALUES OF FRACT INSTEAD. CCCCC RADOLD=-999.0 RADOLD=0.0 FRACTO=-1.0 K=0 J2=0 CCCCC SUM=0.0 DO1120J=1,NUMCLA C CCCCC FJ=D2(J) CCCCC SUM=SUM+FJ CCCCC CUMFJ=SUM C CCCCC FRACT=CUMFJ/AN2 FRACT=YTEMP(J) RAD=FRACT*(2.0*PI) IF(RAD.LE.PI)RAD2=PI-RAD IF(RAD.GT.PI)RAD2=3.0*PI-RAD C CCCCC IF(RAD2.EQ.RADOLD)GOTO1120 IF(FRACT.EQ.FRACTO)GOTO1120 C CCCCC RADOLD=RAD2 CCCCC J2=J2+1 CCCCC K=2*(J2-1)+1 CCCCC KP1=K+1 C K=K+1 J2=J2+1 C X2(K)=0.0 Y2(K)=0.0 D2(K)=J2 C CCCCC X2(KP1)=COS(RAD2) CCCCC Y2(KP1)=SIN(RAD2) K=K+1 X2(K)=COS(RAD2) Y2(K)=SIN(RAD2) D2(K)=J2 C RADTMP=RAD 1125 CONTINUE RADTMP=RADTMP-0.015 IF(RADTMP.LT.RADOLD)GOTO1129 IF(RADTMP.LE.PI)RAD2=PI-RADTMP IF(RADTMP.GT.PI)RAD2=3.0*PI-RADTMP K=K+1 X2(K)=COS(RAD2) Y2(K)=SIN(RAD2) D2(K)=J2 GOTO1125 C 1129 CONTINUE K=K+1 IF(RADOLD.LE.PI)RAD2=PI-RADOLD IF(RADOLD.GT.PI)RAD2=3.0*PI-RADOLD X2(K)=COS(RAD2) Y2(K)=SIN(RAD2) D2(K)=J2 C K=K+1 X2(K)=0.0 Y2(K)=0.0 D2(K)=J2 RADOLD=RAD C IF(IBUGG3.EQ.'ON')WRITE(ICOUT,1121)J,J2,KP1,RAD2,RAD,PI,FRACT, 1CUMFJ, 1FJ,AN2,NUMCLA 1121 FORMAT('J,J2,KP1,RAD2,RAD,PI,FRACT,CUMFJ,FJ,AN2,NUMCLA = ', 13I3,7F9.3,I6) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') 1120 CONTINUE CCCCC NOVEMBER 1993. FOLLOWING SECTION NOW DONE IN ABOVE LOOP. CCCCC NWITHI=KP1 CCCCC JWITHI=J2 C CCCCC DO1130J2=1,JWITHI CCCCC K=2*(J2-1)+1 CCCCC KP1=K+1 CCCCC D2(K)=J2 CCCCC D2(KP1)=J2 C1130 CONTINUE C CCCCC K=NWITHI CCCCC NUMSEG=360 CCCCC ANUMSE=NUMSEG CCCCC NUMSEP=NUMSEG+1 CCCCC DO1140J=1,NUMSEP CCCCC JM1=J-1 C CCCCC K=K+1 C CCCCC DEG=JM1 CCCCC FRACT=DEG/ANUMSE CCCCC RAD=FRACT*(2.0*PI) CCCCC IF(RAD.LE.PI)RAD2=PI-RAD CCCCC IF(RAD.GT.PI)RAD2=3.0*PI-RAD C CCCCC X2(K)=COS(RAD2) CCCCC Y2(K)=SIN(RAD2) CCCCC D2(K)=JWITHI+1.0 C C1140 CONTINUE N2=K NPLOTV=3 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPIE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N2 9012 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)JWITHI,NWITHI 9013 FORMAT('JWITHI,NWITHI = ',I8,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END