SUBROUTINE DPRCSN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN COMPLEX SCRIPT NUMERIC. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRCSN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.9)GOTO1010 GOTO1019 1010 CONTINUE CALL DRCSN1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(ICHARN.GE.10)GOTO1020 GOTO1029 1020 CONTINUE CALL DRCSN2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRCSN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRCSU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN COMPLEX SCRIPT UPPER CASE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRCSU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.6)GOTO1010 GOTO1019 1010 CONTINUE CALL DRCSU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(7.LE.ICHARN.AND.ICHARN.LE.13)GOTO1020 GOTO1029 1020 CONTINUE CALL DRCSU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IF(14.LE.ICHARN.AND.ICHARN.LE.20)GOTO1030 GOTO1039 1030 CONTINUE CALL DRCSU3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1039 CONTINUE C IF(ICHARN.GE.21)GOTO1040 GOTO1049 1040 CONTINUE CALL DRCSU4(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1049 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRCSU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRCU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN COMPLEX UPPER CASE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRCU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.14)GOTO1010 GOTO1019 1010 CONTINUE CALL DRCU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(ICHARN.GE.15)GOTO1020 GOTO1029 1020 CONTINUE CALL DRCU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRCU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRDL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN DUPLEX LOWER CASE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRDL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.11)GOTO1010 GOTO1019 1010 CONTINUE CALL DRDL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(12.LE.ICHARN.AND.ICHARN.LE.24)GOTO1020 GOTO1029 1020 CONTINUE CALL DRDL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IF(ICHARN.GE.25)GOTO1030 GOTO1039 1030 CONTINUE CALL DRDL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1039 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRDL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRDN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN DUPLEX NUMERIC. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRDN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.8)GOTO1010 GOTO1019 1010 CONTINUE CALL DRDN1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(ICHARN.GE.9)GOTO1020 GOTO1029 1020 CONTINUE CALL DRDN2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRDN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRDS(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN DUPLEX SYMBOLS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MARCH 1982. C UPDATED --MARCH 1987. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRDS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHSY(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.9)GOTO1010 GOTO1019 1010 CONTINUE CALL DRDS1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(ICHARN.GE.10)GOTO1020 GOTO1029 1020 CONTINUE CALL DRDS2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRDS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPRDU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR ROMAN DUPLEX UPPER CASE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPRDU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.14)GOTO1010 GOTO1019 1010 CONTINUE CALL DRDU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(ICHARN.GE.15)GOTO1020 GOTO1029 1020 CONTINUE CALL DRDU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPRDU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPREAD(IFROW1,IFROW2,IFCOL1,IFCOL2,ISKIP,INTINF, CCCCC MARCH 1996. ADD IMALEV TO ARGUMENT LIST 1IMACRO,IMACNU,IMACCS,IMALEV,IOSW,ICREAF,NCREAF, 1IREARW, 1ICOMCH,ICOMSW, CCCCC APRIL 1995. ADD FOLLOWING LINE 1IUNFOF,IUNFNR,IUNFMC, CCCCC FEBRUARY 2003. ADD FOLLOWING LINE 1NUMRCM, 1IFCOLL,IFCOLU, 1IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) CCCCC ICOMCH, ICOMSW ARGUMENTS ADDED MAY 1990. C C PURPOSE--READ IN THE VALUES OF A VARIABLE. C THE DATA IS LISTED ACROSS C A LINE IMAGE. C (E.G., X(1) Y(1) Z(1) ETC.) C THE DATA IS READ FORM A MASS STORAGE FILE C OR (IF NO FILE GIVEN) FROM THE DEFAULT INPUT UNIT C (WHICH WILL BE THE TERMINAL). C ASSUMPTION--THE INPUT FILE ALREADY EXISTS; C (THAT IS, DATAPLOT WILL AUTOMATICALLY C OPEN THE FILE C VIA (ON THE UNIVAC 1108), BY AN @ASG,AX ...) C BUT WILL NOT AUTOMATICALLY CREATE THE FILE C VIA (ON THE UNIVAC 1108), BY AN @ASG,UP ...)) C ASSUMPTION--THE COMPUTER SYSTEM IS SUCH THAT C EQUATING THE FILE NAME TO C THE FORTRAN NUMERIC DESIGNATION C OF 31 (OR HOWEVER THE VARIABLE IREANU IS DEFINED C IN INITFO) IS PERMISSIBLE. C NOTE--INPUT FOR THE READ COMMAND MAY POTENTIALLY C COME FROM 2 DIFFERENT SOURCES-- C 1) THE TERMINAL ITSELF; C 2) A FILE; C DIFFERENT SYSTEMS ALLOW DIFFERENT COMBINATIONS C OF THE ABOVE. C ALL SYSTEMS WILL ALLOW INPUT FROM THER TERMINAL ITSELF; C MOST SYSTEMS WILL ALLOW INPUT FROM A FILE; C NOTE--ICOMCH = THE ALLOWABLE COMMENT CHARACTER C ICOMSW = THE COMMENT CHARACTER FLAG/SWITCH (ON/OFF) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1977. C UPDATED --JANUARY 1978. C UPDATED --FEBRUARY 1978. C UPDATED --MAY 1978. C UPDATED --JULY 1978. C UPDATED --NOVEMBER 1978. C UPDATED --NOVEMBER 1980. C UPDATED --JANUARY 1981. C UPDATED --JUNE 1981. C UPDATED --NOVEMBER 1981. C UPDATED --JANUARY 1982. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1985. C UPDATED --SEPTEMBER 1987. (READ MATRIX) C UPDATED --FEBRUARY 1988. (DEACT. COL. LIM. IF READ NON-FILE) C UPDATED --JUNE 1988. (CORRECT DOUBLE ENTRY BY READ FUNCT C UPDATED --DECEMBER 1988. CORRECT BOMB ON 2ND READ PARAMETER C UPDATED --MAY 1989. FIX IRIS PROBLEM--LOOP MAX & CPUMAX C UPDATED --MAY 1990. CHECK FOR COMMENT CHARACTER (UNIX) C UPDATED --MAY 1990. ERROR CHECK FOR FORMATTED READ C UPDATED --JUNE 1990. FIX FORMATTED READ/1 LINE BUG C UPDATED --JULY 1990. UPDATED WRITE/FORMAT STATEMENT C UPDATED --JULY 1990. BUG/TRACE PRINT OF ICOMCH/FL C UPDATED --JULY 1990. COMMENT CHECK BUG FIXED C UPDATED --JULY 1990. RENAME ICOMFL TO ICOMSW C UPDATED --JULY 1993. FIX MATRIX READ (ALAN) C UPDATED --JULY 1993. FIX BOMB IF GOOD READ AFTER C READ NON-EXISTENT FILE C UPDATED --MARCH 1994. FIX BUG WHERE DELETE AND C RETAIN WIPED OUT PARAMETERS C CREATED VIA READ PARAMETER C UPDATED --APRIL 1995. SUPPORT FOR UNFORMATTED READ C UPDATED --SEPTEMBER 1995. ROW LIMITS & BLANK LINES PROBLEM C UPDATED --MARCH 1996. FIX BUG WHERE TERMINAL READ C NESTED WITHIN A MACRO C UPDATED --APRIL 1996. FOR READ STRING, IGNORE SET C READ FORMAT C UPDATED --OCTOBER 1997. SUPPORT "SKIP AUTOMATIC", C READ UNTIL FIND "----" C UPDATED --NOVEMBER 1998. READ MORE THAN 100 VARIABLES C (MAKE PARAMETER SETTABLE) C UPDATED --DECEMBER 1999. READ ROWID C UPDATED --MARCH 2001. FIX BUGS: C A) UPDATE LIMIT ON MAX COLUMNS C B) OFFSET FOR UNFORMATTED READ C C) MAX FOR ROW LIMITS C UPDATED --JULY 2002. SUPPORT FOR QUOTES ON C FILE NAMES. C UPDATED --FEBRUARY 2003. UP MAXIMUM NUMBER OF C CHARACTERS READ FROM ONE C RECORD OF DATA FILE (MAKE C SETTABLE TO PARAMETER) C UPDATED --FEBRUARY 2003. AUTOMATICALLY DETERMINE C NUMBER OF VARIABLES IF NO C LIST GIVEN. C UPDATED --JUNE 2003. HANDLE HYPHENS INSIDE OF QUOTED C FILE NAMES CORRECTLY. C UPDATED --JULY 2003. BUG WHEN FILE NAME < 80 C CHARACTERS, BUT COMMAND LINE C > 80 CHARACTERS C UPDATED --AUGUST 2003. QUOTES ON FILE NAMES C AUTOMATIC FOR READ C UPDATED --JANUARY 2004. IF AUTOMATICALLY DETERMINE C VARIABLE LIST, CHECK FIRST C LINE FOR VARIABLE LIST C UPDATED --JANUARY 2004. SOME RECODING FOR BETTER C CLARITY C UPDATED --JANUARY 2004. HANDLE CHARACTER DATA C UPDATED --OCTOBER 2004. WHEN READING VARIABLES, IF C NUMBER OF ITEMS IS GREATER C THAN NUMBER OF ITEMS READ, C PAD WITH "MISSING VALUE" C (BASED ON VALUE OF IREAPD) C UPDATED --OCTOBER 2004. SET READ SUBSET C C UPDATED --DECEMBER 2004. IF GUI RUNNING (SET GUI), THEN C DO NOT ALLOW TERMINAL READ C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IMACRO CHARACTER*12 IMACCS C CHARACTER*4 IOSW C CHARACTER*80 ICREAF C CHARACTER*4 IREARW C CHARACTER*4 IGRPA2 CHARACTER*4 ICFLAG C CHARACTER*4 IBUGS2 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASEQ CHARACTER*4 ICASEA CHARACTER*4 IECASE CHARACTER*4 ISTOR1 CHARACTER*4 ISTOR2 CHARACTER*4 ISTOR3 CHARACTER*4 IB CHARACTER*4 IEND CHARACTER*4 JVNAM1 CHARACTER*4 JPNAM1 CHARACTER*4 JMNAM1 CHARACTER*4 JFNAM1 CHARACTER*4 JUNAM1 CHARACTER*4 JENAM1 CHARACTER*4 JVNAM2 CHARACTER*4 JPNAM2 CHARACTER*4 JMNAM2 CHARACTER*4 JFNAM2 CHARACTER*4 JUNAM2 CHARACTER*4 JENAM2 CHARACTER*4 IH1 CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 ICASRE CHARACTER*4 IOFILE CHARACTER*4 IOTERM C CHARACTER*4 IFILQ2 C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 C CCCCC CHARACTER*80 ICANS CHARACTER*200 ICANS CCCCC CHARACTER*80 ISTRIN C CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 NEWNAM C CHARACTER*4 ICASTO C CHARACTER*4 IHMAT1 CHARACTER*4 IHMAT2 C FOLLOWING 3 LINES MAY 1990. CHARACTER*80 IAJUNK CHARACTER*4 ICOMCH CHARACTER*4 ICOMSW C CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1995 CHARACTER*4 LINETY C CCCCC NOVEMBER 1998. DEFINE MAXRDV TO DEFINE MAXIMUM NUMBER OF CCCCC VARIABLES. C CCCCC MARCH 2001. UP LIMIT (MATRICES IN PARTICULAR CAN HAVBE MORE) CCCCC PARAMETER(MAXRDV=250) PARAMETER(MAXRDV=1000) PARAMETER(MAXCHV=20) C CCCCC THE FOLLOWING LINES ADDED FEBRUARY 2003. CHARACTER*4 IVRLST CHARACTER*4 IVLIST(MAXRDV) CHARACTER*4 IVLIS2(MAXRDV) CHARACTER*4 IASAVE(MAXRDV) C INTEGER IFCOLL(50) INTEGER IFCOLU(50) INTEGER ITYPE(MAXRDV) CHARACTER*4 ICLIST(MAXRDV) CHARACTER*4 ICLIS2(MAXRDV) C DIMENSION JVNAM1(MAXRDV) DIMENSION JPNAM1(MAXRDV) DIMENSION JMNAM1(MAXRDV) DIMENSION JFNAM1(MAXRDV) DIMENSION JUNAM1(MAXRDV) DIMENSION JENAM1(MAXRDV) C DIMENSION NIV(MAXRDV) C DIMENSION JVNAM2(MAXRDV) DIMENSION JPNAM2(MAXRDV) DIMENSION JMNAM2(MAXRDV) DIMENSION JFNAM2(MAXRDV) DIMENSION JUNAM2(MAXRDV) DIMENSION JENAM2(MAXRDV) C DIMENSION IEN(MAXRDV) DIMENSION IECOL2(MAXRDV) DIMENSION IECASE(MAXRDV) DIMENSION PVAL(MAXRDV) DIMENSION IFSTA2(MAXRDV) DIMENSION IFSTO2(MAXRDV) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOFO.INC' INCLUDE 'DPCOF2.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOST.INC' CCCCC MARCH 2001. ADD FOLLOWING LINE INCLUDE 'DPCOMC.INC' CCCCC APRIL 1995. ADD FOLLOWING 4 LINES INCLUDE 'DPCOZ2.INC' DIMENSION XSCRT(3*MAXOBW) C DIMENSION X0(MAXRCL) CHARACTER*24 IXC(MAXCHV) C DIMENSION ISTOR1(MAXRCL) DIMENSION ISTOR2(MAXRCL) DIMENSION ISTOR3(MAXRCL) DIMENSION IB(MAXRCL) C EQUIVALENCE (G2RBAG(1),XSCRT(1)) CHARACTER*4 IFMFLG CHARACTER*4 ICRFLG 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='DPRE' ISUBN2='AD ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IFOUND='YES' IERROR='NO' C ICASRE='-999' IOFILE='-999' IOTERM='-999' C IFILQ2=IFILQU IFILQU='ON' C CCCCC FEBRUARY 2003: ADD FOLLOWING LINE. CCCCC IF NO VARIABLE LIST GIVEN, THEN TWO CASES: CCCCC 1) IF SKIP AUTOMATIC ON, THEN READ PREVIOUS LINE TO CCCCC DETERMINE VARIABLE LIST. CCCCC 2) IF SKIP AUTOMATIC OFF, THEN READ FIRST LINE TO CCCCC DETERMINE NUMBER OF VARIABLES. NAME THEM X1, X2, ETC. C IVRLST='YES' DO10I=1,132 IASAVE(I)=' ' 10 CONTINUE DO15I=1,MAXRDV IVLIST(I)=' ' IVLIS2(I)=' ' ITYPE(I)=0 15 CONTINUE DO13I=1,MAXCHV IXC(I)=' ' ICLIST(I)=' ' ICLIS2(I)=' ' 13 CONTINUE IGRPA2=IGRPAU C CCCCC THE FOLLOWING LINE WAS INSERTED MAY 1989 CCCCC MARCH 2001. SET VALUE TO MAX INTEGER CCCCC IBILLI=10**9 IBILLI=I1MACH(9) I2=0 NUMVRD=0 NUMPRD=0 NUMFRD=0 C AFROW2=IFROW2 C MAXN2=MAXCHF C IMATC1=(-999) IMATNR=(-999) IMATNC=(-999) CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1995 LINETY='-999' NCALL=0 NCOLS=0 C C *************************** C ** TREAT THE READ CASE ** C *************************** C CCCCC NOVEMBER 1998. DEFINE MAXRDV TO DEFINE MAXIMUM NUMBER OF CCCCC VARIABLES. C MAXV2=MAXRDV MAXP2=MAXRDV MAXM2=MAXRDV MAXF2=MAXRDV MAXU2=MAXRDV MAXE2=MAXRDV C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IFROW1,AFROW2 52 FORMAT('IFROW1,AFROW2 = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IFCOL1,IFCOL2,NUMRCM 53 FORMAT('IFCOL1,IFCOL2,NUMRCM = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ISKIP,IBUGS2,IBUGQ 54 FORMAT('ISKIP,IBUGS2,IBUGQ = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IOSW 55 FORMAT('IOSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)IMACRO,IMACNU,IMACCS 56 FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)IRD,IRD2 58 FORMAT('IRD,IRD2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IBUGS2,ISUBRO,IERROR 63 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IWIDTH 64 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,65)(IANSLC(I),I=1,MIN(100,IWIDTH)) 65 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,71)IREANU 71 FORMAT('IREANU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IREANA 72 FORMAT('IREANA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)IREAST 73 FORMAT('IREAST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)IREAFO 74 FORMAT('IREAFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)IREAAC 75 FORMAT('IREAAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)IREAFO 76 FORMAT('IREAFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)IREACS 77 FORMAT('IREACS = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81)NUMNAM 81 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,82)N2,MAXN2 82 FORMAT('N2,MAXN2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)NCREAF 84 FORMAT('NCREAF = ',I8) CALL DPWRST('XXX','BUG ') IF(NCREAF.GE.1)THEN WRITE(ICOUT,85)(ICREAF(I:I),I=1,NCREAF) 85 FORMAT('(ICREAF(I:I),I=1,NCREAF) = ',80A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,86)IREARW 86 FORMAT('IREARW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,87)ICOMCH,ICOMSW 87 FORMAT('ICOMCH,ICOMSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C ******************************************************* C ** STEP 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='1' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LT.1)THEN IERROR='YES' GOTO8800 ENDIF C C ***************************************** C ** STEP 1B-- ** C ** DETERMINE THE TYPE OF READ CASE-- ** C ** 1) VARIABLE ** C ** 2) PARAMETER ** C ** 3) FUNCTION (= STRING) ** C ** 4) MATRIX ** C ***************************************** C ICASRE='VARI' IF(IHARG(1).EQ.'PARA'.AND.IHARG2(1).EQ.'METE')ICASRE='PARA' IF(IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')ICASRE='FUNC' IF(IHARG(1).EQ.'STRI'.AND.IHARG2(1).EQ.'NG')ICASRE='FUNC' IF(IHARG(1).EQ.'MATR'.AND.IHARG2(1).EQ.'IX')ICASRE='MATR' IF(IHARG(1).EQ.'ROW '.AND.IHARG2(1).EQ.' '.AND. 1 IHARG(2).EQ.'LABE'.AND.IHARG2(2).EQ.'LS')ICASRE='ROWI' IF(IHARG(1).EQ.'ROW '.AND.IHARG2(1).EQ.' '.AND. 1 IHARG(2).EQ.'LABE'.AND.IHARG2(2).EQ.'L ')ICASRE='ROWI' C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,155)ICASRE 155 FORMAT('ICASRE = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C C ****************************************************** C ** STEP 2A-- ** C ** DETERMINE THE TYPE OF READ CASE-- ** C ** 1) FROM TERMINAL; ** C ** 2) FROM FILE; ** C ** NOTE--IOTERM WILL = 'YES' ONLY IN EXPLICIT ** C ** TERMINAL CASE ** C ** (THAT IS, ONLY WHEN INPUT IOSW ** C ** = 'TERM') ** C ** NOTE--IOFILE WILL = 'YES' ONLY IN FILE CASE. ** C ****************************************************** C ISTEPN='2A' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 200 CONTINUE IWORD=2 IF(ICASRE.EQ.'PARA')IWORD=3 IF(ICASRE.EQ.'FUNC')IWORD=3 IF(ICASRE.EQ.'MATR')IWORD=3 IF(ICASRE.EQ.'ROWI')THEN IWORD=4 IF(NUMARG.LE.2)THEN IOFILE='NO' GOTO202 ENDIF ENDIF CALL DPFILE(IANSLC,IWIDTH,IWORD, 1IOFILE,IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 202 CONTINUE C IOTERM='NO' IF(IOFILE.EQ.'NO'.AND.IOSW.EQ.'TERM')IOTERM='YES' C CCCCC DECEMBER 2004. IF GUI RUNNING, DO NOT ALLOW TERMINAL READ. C IF(IOFILE.EQ.'NO' .AND. IGUIFL.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,211) 211 FORMAT('***** ERROR FROM READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,213) 213 FORMAT(' TERMINAL READS (I.E., READ WITH NO FILE NAME ', 1 'SPECIFIED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,215) 215 FORMAT(' ARE NOT PERMITTED WHEN RUNNING DATAPLOT FROM ', 1 'THE GRAPHICAL USER INTERFACE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,217) 217 FORMAT(' ALTERNATIVELY, YOU CAN DO ONE OF THE FOLLOWING:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,219) 219 FORMAT(' 1) YOU CAN ENTER THE DATA DIRECTLY FROM THE ', 1 'DATASHEET.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,221) 221 FORMAT(' 2) FROM THE COMMAND LINE WINDOW, YOU CAN USE ', 1 'THE DATA COMMAND AS FOLLOWS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,223) 223 FORMAT(' LET Y = DATA value1 value2 ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,225) 225 FORMAT(' 3) THE FIRST TWO METHODS ARE USEFUL FOR SMALL ', 1 'AMOUNTS OF DATA.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,227) 227 FORMAT(' FOR MORE THAN A FEW DATA POINTS, IT IS ', 1 'RECOMMENDED THAT YOU') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,229) 229 FORMAT(' CREATE THE DATA IN AN ASCII FILE AND THEN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,231) 231 FORMAT(' READ THE DATA FROM THAT FILE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C ************************************* C ** STEP 2B-- ** C ** IF HAVE THE FILE INPUT CASE-- ** C ** COPY OVER VARIABLES ** C ************************************* C ISTEPN='2B' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'YES')THEN C IOUNIT=IREANU IFILE=IREANA ISTAT=IREAST IFORM=IREAFO IACCES=IREAAC IPROT=IREAPR ICURST=IREACS C ISUBN0='READ' IERRFI='NO' C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,1183)IOUNIT 1183 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1184)IFILE 1184 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1185)ISTAT,IFORM,IACCES,IPROT,ICURST 1185 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 1 A12,2X,A12,2X,A12,2X,A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)ISUBN0,IERRFI 1186 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C ENDIF C C *********************************************** C ** STEP 2C-- ** C ** IF HAVE THE FILE INPUT CASE-- ** C ** CHECK TO SEE IF THE READ FILE MAY EXIST ** C *********************************************** C ISTEPN='2C' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'YES')THEN C IF(ISTAT.EQ.'NONE')THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** IMPLEMENTATION ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE DESIRED READING CANNOT BE CARRIED OUT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' BECAUSE THE INTERNAL VARIABLE IREAST WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' ALLOWS SUCH READING HAS BEEN SET TO NONE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)ISTAT,IREAST 1217 FORMAT('ISTAT,IREAST = ',A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1218) 1218 FORMAT(' ALL READING MUST BE DONE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1219) 1219 FORMAT(' DIRECTLY FROM THE TERMINAL.') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF ENDIF C C ************************************* C ** STEP 2D-- ** C ** IF HAVE THE FILE INPUT CASE-- ** C ** EXTRACT THE FILE NAME ** C ************************************* C ISTEPN='2D' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'YES')THEN C DO1310I=1,200 ICANS(I:I)=IANSLC(I) 1310 CONTINUE C ISTART=1 ISTOP=IWIDTH IWORD=2 IF(ICASRE.EQ.'PARA')IWORD=3 IF(ICASRE.EQ.'FUNC')IWORD=3 IF(ICASRE.EQ.'MATR')IWORD=3 IF(ICASRE.EQ.'ROWI')IWORD=4 CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD, 1 ICOL1,ICOL2,IFILE,NCFILE, 1 IBUGS2,ISUBRO,IERROR) C IF(NCFILE.LT.1)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1341) 1341 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1342) 1342 FORMAT(' A USER FILE NAME IS REQUIRED IN THE READ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1344) 1344 FORMAT(' COMMAND (FOR EXAMPLE, READ CALIB.DAT X Y Z)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1345) 1345 FORMAT(' BUT NONE WAS GIVEN HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1346) 1346 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1347)(IANSLC(I),I=1,MIN(100,IWIDTH)) 1347 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF ENDIF C ENDIF C C ************************************* C ** STEP 2E-- ** C ** IF HAVE THE FILE INPUT CASE-- ** C ** OPEN THE FILE ** C ************************************* C ISTEPN='2E' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'YES')THEN C IREWIN='ON' ICRFLG='ROW' IF(NCREAF.GT.0.AND.IOFILE.EQ.'YES')THEN IF(ICREAF(1:5).EQ.'(UNFO'.AND.ICASRE.EQ.'VARI')THEN IFORM='UNFORMATTED' IFMFLG='ON' IF(ICREAF(13:16).EQ.'COLU')ICRFLG='COLU' IF(ICREAF(1:5).EQ.'(COLU')ICRFLG='COLU' ELSEIF(ICREAF(1:5).EQ.'(UNFO'.AND.ICASRE.EQ.'MATR')THEN IF(IUNFMC.GT.0)THEN IFORM='UNFORMATTED' IFMFLG='ON' ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1441) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1442) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1443) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1444) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF ELSE IFORM='FORMATTED' IFMFLG='OFF' ENDIF ELSE IFORM='FORMATTED' IFMFLG='OFF' ENDIF 1441 FORMAT('***** ERROR IN DPREAD--') 1442 FORMAT(' FOR UNFORMATTED READS OF MATRICES, THE ', 1 ' FOLLOWING COMMAND IS REQUIRED:') 1443 FORMAT(' SET UNFORMATTED COLUMNS ') 1444 FORMAT(' WHERE IS THE NUMBER OF COLUMNS IN THE ', 1 'MATRTIX.') C IF(IREACS(1:4).EQ.'CLOS') 1 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 IF(IREACS(1:4).EQ.'CLOS')IREACS='OPEN' C ENDIF C C ****************************************** C ** STEP 2F-- ** C ** FOR THE 2 CASES-- ** C ** 1) TERMINAL INPUT; ** C ** 2) FILE INPUT; ** C ** DEFINE THE INPUT READ UNIT NUMBER, ** C ** AND OTHER VARIABLES NEEDED ** C ** FOR UPCOMING READS. ** C ****************************************** C ISTEPN='2F' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IRD2=IRD IF(IMACCS.EQ.'OPEN'.OR.IMALEV.GE.1)THEN IRD2=IMACNU ENDIF IF(IOFILE.EQ.'YES')IRD2=IREANU IF(IOTERM.EQ.'YES')IRD2=IRD C IOUNIT=IRD2 C C ***************************************** C ** STEP 3-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='3' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO390 DO300J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')THEN ICASEQ='SUBS' ILOCQ=J1 GOTO390 ELSEIF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')THEN ICASEQ='SUBS' ILOCQ=J1 GOTO390 ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')THEN ICASEQ='FOR' ILOCQ=J1 GOTO390 ENDIF 300 CONTINUE 390 CONTINUE IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,391)NUMARG,ILOCQ 391 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C 490 CONTINUE C C ****************************************************** C ** STEP 4-- ** C ** DETERMINE THE TYPE AND NUMBER OF ITEMS ** C ** TO BE READ . ** C ** NUMALL = TOTAL NUMBER OF READ ITEMS ** C ** (AS DETERMINED BY INCLUDING ONLY ALL ** C ** BEFORE 'SUBSET' OR 'EXCEPT' OR 'FOR') ** C ** NUMV = NUMBER OF VARIABLES TO BE READ ; ** C ** NUMP = NUMBER OF PARAMETERS TO BE READ ; ** C ** NUMM = NUMBER OF MODELS TO BE READ ** C ** (SHOULD = 0 OR 1) ** C ** NUMF = NUMBER OF FUNCTIONS TO BE READ ** C ** NUMU = NUMBER OF UNKNOWNS TO BE READ ; ** C ** NUME = TOTAL NUMBER OF READ ITEMS ** C ** (SHOULD = NUMALL); ** C ****************************************************** C ISTEPN='4' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IV=0 IP=0 IM=0 IF=0 IU=0 IE=0 C JMIN=1 IF(IOFILE.EQ.'NO'.AND.ICASRE.EQ.'PARA')JMIN=2 IF(IOFILE.EQ.'NO'.AND.ICASRE.EQ.'FUNC')JMIN=2 IF(IOFILE.EQ.'NO'.AND.ICASRE.EQ.'MATR')JMIN=2 IF(IOFILE.EQ.'NO'.AND.ICASRE.EQ.'ROWI')JMIN=3 IF(IOFILE.EQ.'YES')JMIN=2 IF(IOFILE.EQ.'YES'.AND.ICASRE.EQ.'PARA')JMIN=3 IF(IOFILE.EQ.'YES'.AND.ICASRE.EQ.'FUNC')JMIN=3 IF(IOFILE.EQ.'YES'.AND.ICASRE.EQ.'MATR')JMIN=3 IF(IOFILE.EQ.'YES'.AND.ICASRE.EQ.'ROWI')JMIN=4 C CCCCC JULY 2002: QUOTED FILE NAMES MAY CONTAIN SPACES. CCCCC DETERMINE HOW MANY ARGUMENTS FILE NAME MAY CONTAIN. CCCCC JUNE 2003: UPDATE TO INCLUDE HYPHENS AS WELL AS SPACES. C IF(IFILE(1:1).EQ.'"')THEN DO421I=80,1,-1 IF(IFILE(I:I).NE.' ')THEN ILAST=I GOTO424 ENDIF 421 CONTINUE 424 CONTINUE ICOUNT=0 ISPAC=0 DO426I=1,ILAST IF((IFILE(I:I).EQ.' '.OR.IFILE(I:I).EQ.'-') .AND. 1 ISPAC.EQ.0)THEN ISPAC=1 ICOUNT=ICOUNT+1 ELSEIF((IFILE(I:I).NE.' '.AND.IFILE(I:I).NE.'-') .AND. 1 ISPAC.EQ.1)THEN ISPAC=0 ENDIF 426 CONTINUE JMIN=JMIN+ICOUNT ENDIF C JMAX=ILOCQ-1 IF(ICASRE.EQ.'ROWI')JMAX=JMIN IF(ICASRE.EQ.'MATR')JMAX=JMIN+MAXCOM-1 C IF(ICASRE.EQ.'MATR')THEN IF(JMAX.GT.JMIN+MAXRDV-1)JMAX=JMIN+MAXRDV-1 ENDIF C IF(ICASRE.EQ.'MATR')IHMAT1=IHARG(JMIN) IF(ICASRE.EQ.'MATR')IHMAT2=IHARG2(JMIN) C IVALMA=0 NUMALL=0 NUMALL=JMAX-JMIN+1 IF(ICASRE.EQ.'VARI'.AND.NUMALL.LE.0)IVRLST='NO' IF(IVRLST.EQ.'NO' .AND. ICASRE.EQ.'VARI')THEN C CCCCC FIRST, CASE WHERE SKIP AUTOMATIC IS ON, RETRIEVE CCCCC VARIABLE LIST FROM LINE JUST BEFORE THE "----". C IF(ISKIP.EQ.-1.AND.IOFILE.EQ.'YES')THEN DO4578I=1,MAXOBV ILINE=I NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) C IF(IERROR.EQ.'YES')GOTO8800 IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND. 1 NUMCHA.EQ.3)THEN REWIND IOUNIT GOTO8800 ELSEIF(IA(1).EQ.'-'.AND.IA(2).EQ.'-'.AND.IA(3).EQ.'-'.AND. 1 IA(4).EQ.'-')THEN GOTO4581 ELSE DO4511J=1,132 IASAVE(J)=IA(J) 4511 CONTINUE ENDIF 4578 CONTINUE 4581 CONTINUE IF(ILINE.GT.1)THEN IFRST=0 ILAST=0 INEW=0 IVAR=0 CALL DPUPPE(IASAVE,132,IASAVE,IBUGS2,IERROR) DO4583J=1,132 IF(IASAVE(J)(1:1).EQ.' ')THEN IF(INEW.EQ.1)THEN IVAR=IVAR+1 ILAST=J NCHAR=ILAST-IFRST+1 DO4585K=1,MIN(4,NCHAR) IVLIST(IVAR)(K:K)=IASAVE(IFRST+K-1)(1:1) 4585 CONTINUE IF(NCHAR.GE.5)THEN DO4587K=5,MIN(8,NCHAR) IVLIS2(IVAR)(K-4:K-4)=IASAVE(IFRST+K-1)(1:1) 4587 CONTINUE ENDIF INEW=0 ENDIF ELSE ILAST=J IF(INEW.EQ.0)THEN INEW=1 IFRST=J ENDIF ENDIF 4583 CONTINUE REWIND IOUNIT JMIN=1 JMAX=IVAR ENDIF C CCCCC SECOND CASE: SKIP AUTOMATIC IS OFF CCCCC 1) SET COLUMN LIMITS, ROW LIMITS CCCCC 2) SKIP OVER HEADER LINES (IF NEEDED) CCCCC 3) READ SINGLE LINE OF DATA CCCCC 4) DETERMINE NUMBER OF COLUMNS OF DATA IN THAT LINE CCCCC 5) SET VARIABLE NAMES TO X1, ..., XK CCCCC IF IVARLA="ON", FIRST LINE READ SHOULD BE VARIABLE NAMES CCCCC 6) REWIND C ELSEIF(IOFILE.EQ.'YES')THEN IF(ISKIP.GE.0)THEN IFRMIN=IFROW1 IFRMAX=IFROW1+ISKIP IF(IFRMAX.LT.IFRMIN)IFRMAX=IFRMIN MINCO2=1 MAXCO2=NUMRCM IFCOL3=IFCOL1 IFCOL4=IFCOL2 IF(IFRMIN.LT.IFRMAX)THEN DO4591IFROW=IFRMIN,IFRMAX-1 NUMCHA=-1 CALL DPREFI( 1 IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA, 1 ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 4591 CONTINUE ENDIF C IF(IVARLA.EQ.'OFF')THEN NUMLRD=0 4592 CONTINUE DO4597I=1,MAXRCL ISTOR1(I)=' ' ISTOR2(I)=' ' ISTOR3(I)=' ' IB(I)=' ' 4597 CONTINUE CALL DPREAL(IRD2,IFCOL3,IFCOL4,MINCO2,MAXCO2,X0,NUMDPL, 1 IXC,NXC, 1 ICASRE,IFUNC2,N2,MAXN2, 1 IMACRO,IMACNU,IMACCS, 1 IANSLC,IWIDTH,IREACS,ISTOR1,ISTOR2,IEND,NUMLRD, 1 IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 ICOMCH,ICOMSW,LINETY,IGRPA2, 1 IFCOLL,IFCOLU,ITYPE,NCOLS,NCALL,IREADL,PREAMV, 1 MAXRDV,MAXCHV, 1 IDECPT, 1 IB, 1 IERRFI,IBUGS2,ISUBRO,IERROR) IF(LINETY.EQ.'BLAN')GOTO4592 NUMLRD=0 IF(NUMDPL.GT.0)THEN DO4593J=1,NUMDPL IVLIST(J)='X ' IVLIS2(J)=' ' IF(J.LE.9)THEN WRITE(IVLIST(J)(2:2),'(I1)')J ELSEIF(J.LE.99)THEN WRITE(IVLIST(J)(2:3),'(I2)')J ELSE WRITE(IVLIST(J)(2:4),'(I3)')J ENDIF 4593 CONTINUE ENDIF REWIND IOUNIT NCALL=0 NCOLS=0 JMIN=1 JMAX=NUMDPL ELSEIF(IVARLA.EQ.'ON')THEN NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IASAVE,NUMCHA,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO8800 C IFRST=0 ILAST=0 INEW=0 IVAR=0 CALL DPUPPE(IASAVE,132,IASAVE,IBUGS2,IERROR) DO34583J=1,132 IF(IASAVE(J)(1:1).EQ.' ')THEN IF(INEW.EQ.1)THEN IVAR=IVAR+1 ILAST=J NCHAR=ILAST-IFRST+1 DO34585K=1,MIN(4,NCHAR) IVLIST(IVAR)(K:K)=IASAVE(IFRST+K-1)(1:1) 34585 CONTINUE IF(NCHAR.GE.5)THEN DO34587K=5,MIN(8,NCHAR) IVLIS2(IVAR)(K-4:K-4)=IASAVE(IFRST+K-1)(1:1) 34587 CONTINUE ENDIF INEW=0 ENDIF ELSE ILAST=J IF(INEW.EQ.0)THEN INEW=1 IFRST=J ENDIF ENDIF 34583 CONTINUE CCCCC DON'T REWIND FILE, DON'T WANT TO READ VARIABLE LABELS AS DATA CCCCC REWIND IOUNIT JMIN=1 JMAX=IVAR ENDIF C ENDIF ENDIF ENDIF 4589 CONTINUE C IF(JMIN.GT.JMAX)GOTO4290 IF(ICASRE.EQ.'ROWI')GOTO4290 C C JANUARY 2004. THE DPREAL ROUTINE CAN NOW RETURN CHARACTER AS C WELL AS NUMERIC DATA. FOR THE VARIABLE READ CASE, READ FIRST C LINE OF FILE TO EXTRACT THE TYPES FOR EACH OF THE VARIABLES. C FOLLOWING CONDITIONS NEED TO APPLY: C C 1. THIS IS THE VARIABLE (AS OPPOSSED TO STRING, PARAMETER, MATRIX) C READ CASE. C C 2. THE CONVERT CHARACTER CASE IS SET TO CHARACTER (AS OPPOSSED C TO IGNORE OR ERROR). THIS IS DETERMINED BY VALUE OF IGRPAU. C C 3. THE READ IS FROM FILE RATHER THAN THE KEYBOARD. FOR THE C KEYBOARD READ CASE, IGRPAU IS SET TO IGNORE. C C 4. IF A SET READ FORMAT HAS BEEN SET, NO CHARACTER DATA WILL C BE READ. C ICFLAG='YES' IF(IGRPAU.NE.'CHAR')ICFLAG='NO' IF(IOFILE.NE.'YES')ICFLAG='NO' IF(ICASRE.NE.'VARI')ICFLAG='NO' IF(NCREAF.GT.0)ICFLAG='NO' C IF(ICFLAG.EQ.'YES')THEN C MINCO2=1 MAXCO2=NUMRCM IFCOL3=IFCOL1 IFCOL4=IFCOL2 ITEMP=IFROW1+ISKIP-1 IF(ITEMP.GT.0)THEN DO17380IFROW=1,ITEMP NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA, 1 ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')THEN IGRPA2='IGNO' ICFLAG='NO' GOTO17399 ENDIF IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND. 1 NUMCHA.EQ.3)THEN IGRPA2='IGNO' ICFLAG='NO' GOTO17399 ENDIF 17380 CONTINUE ENDIF C 17391 CONTINUE NCALL=0 NCOLS=0 CALL DPREAL(IRD2,IFCOL3,IFCOL4,MINCO2,MAXCO2,X0,NUMDPL, 1 IXC,NXC, 1 ICASRE,IFUNC2,N2,MAXN2, 1 IMACRO,IMACNU,IMACCS, 1 IANSLC,IWIDTH,IREACS,ISTOR1,ISTOR2,IEND,NUMLRD, 1 IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 ICOMCH,ICOMSW,LINETY,IGRPA2, 1 IFCOLL,IFCOLU,ITYPE,NCOLS,NCALL,IREADL,PREAMV, 1 MAXRDV,MAXCHV, 1 IDECPT, 1 IB, 1 IERRFI,IBUGS2,ISUBRO,IERROR) IF(LINETY.EQ.'BLAN')GOTO17391 C IF(NXC.LE.0)THEN ICFLAG='NO' IGRPA2='IGNO' GOTO17399 ENDIF C 17399 CONTINUE REWIND(IOUNIT) NCALL=0 NCOLS=0 ENDIF C ICNTNU=0 ICNTCH=0 ICOUNT=0 C DO4200J=JMIN,JMAX ICOUNT=ICOUNT+1 IF(IVRLST.EQ.'NO')THEN IH1=IVLIST(J) IH2=IVLIS2(J) ELSE IH1=IHARG(J) IH2=IHARG2(J) ENDIF C C ********** C THE FOLLOWING 5 LINES OF CODE IS FOR READ MATRIX. C IT ALLOWS COLUMN VECTOR NAMES TO BE FORMED C FROM THE BASE MATRIX NAME C BY THE APPENDING OF NUMBERS 1, 2, 3, ... C SEPTEMBER 1987 C ********** C IF(ICASRE.EQ.'MATR')THEN IVALMA=IVALMA+1 CALL DPAPN2(IHMAT1,IHMAT2,IVALMA, 1 IH1,IH2,IBUGS2,ISUBRO,IERROR) ENDIF C C *************** C THE FOLLOWING CODE ALLOWS THE TO KEYWORD C TO BE ACTIVATED, AS IN C READ FILE.EXT Y1 TO Y10 C DECEMBER 1986 C *************** C ICASTO='OFF' IF(IH1.EQ.'TO ')THEN ICASTO='ON' JM1=J-1 JP1=J+1 CALL DPEXTL(IHARG(JM1),IHARG2(JM1),IHARG(JP1),IHARG2(JP1), 1 KNUMB,IVAL1,IVAL2,IBUGS2,ISUBRO,IERROR) C IVA1P1=IVAL1+1 IVA2M1=IVAL2-1 IF(IVA1P1.GT.IVA2M1)GOTO4200 IVAL=IVAL1 ELSE GOTO4219 ENDIF 4215 CONTINUE IVAL=IVAL+1 IF(IVAL.GE.IVAL2)GOTO4200 C CALL DPAPNU(IHARG(JM1),IHARG2(JM1),KNUMB,IVAL, 1 IH1,IH2,IBUGS2,ISUBRO,IERROR) 4219 CONTINUE C C JANUARY 2004: CHECK WHETHER NAME SHOULD BE ADDED TO C REGULAR NAME LIST OR CHARACTER VARIABLE NAME LIST. C IF(ICFLAG.EQ.'YES')THEN IF(ITYPE(ICOUNT).EQ.1)THEN ICNTCH=ICNTCH+1 IF(ICNTCH.GT.MAXCHV)GOTO4200 ICLIST(ICNTCH)=IH1 ICLIS2(ICNTCH)=IH2 GOTO4200 ELSE ICNTNU=ICNTNU+1 ENDIF ENDIF C ICASEA=' ' DO4300I=1,NUMNAM I2=I IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN IF(IUSE(I).EQ.'V')THEN ICASEA='V' IV=IV+1 IF(IV.GT.MAXV2)GOTO4370 JVNAM1(IV)=IH1 JVNAM2(IV)=IH2 NIV(IV)=IN(I2) C IF(ICASRE.EQ.'VARI')GOTO4370 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4311) 4311 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4312) 4312 FORMAT(' A NAME IN THE LIST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4313) 4313 FORMAT(' OF VARIABLES TO BE READ ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4314) 4314 FORMAT(' INCLUDED THE NAME OF A ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4315) 4315 FORMAT(' PREVIOUSLY-DEFINED PARAMETER OR FUNCTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4316)IH1,IH2 4316 FORMAT(' THE NAME OF THE PARAMETER OR FUNCTION WAS ', 1 2A4,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4317) 4317 FORMAT(' NO READ WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C ELSEIF(IUSE(I).EQ.'P')THEN ICASEA='P' IP=IP+1 IF(IP.GT.MAXP2)GOTO4370 JPNAM1(IP)=IH1 JPNAM2(IP)=IH2 PVAL(IP)=VALUE(I2) C IF(ICASRE.EQ.'PARA')GOTO4370 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4321) 4321 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4322) 4322 FORMAT(' A NAME IN THE LIST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4323) 4323 FORMAT(' OF PARAMETERS TO BE READ ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4324) 4324 FORMAT(' INCLUDED THE NAME OF A ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4325) 4325 FORMAT(' PREVIOUSLY-DEFINED VARIABLE OR FUNCTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4326)IH1,IH2 4326 FORMAT(' THE NAME OF THE VARIABLE OR FUNCTION WAS ', 1 2A4,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4327) 4327 FORMAT(' NO READ WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C ELSEIF(IUSE(I).EQ.'M')THEN ICASEA='M' IM=IM+1 IF(IM.GT.MAXM2)GOTO4370 JMNAM1(IM)=IH1 JMNAM2(IM)=IH2 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4331) 4331 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4332) 4332 FORMAT(' A NAME IN THE LIST OF VARIABLES TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4334) 4334 FORMAT(' READ INCLUDED THE NAME OF A ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4335) 4335 FORMAT(' PREVIOUSLY-DEFINED MODEL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4336)IH1,IH2 4336 FORMAT(' THE NAME OF THE MODEL WAS ',2A4,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4337) 4337 FORMAT(' NO READ WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C ELSEIF(IUSE(I).EQ.'F')THEN ICASEA='F' IF=IF+1 IF(IF.GT.MAXF2)GOTO4370 JFNAM1(IF)=IH1 JFNAM2(IF)=IH2 IFSTA2(IF)=IVSTAR(I2) IFSTO2(IF)=IVSTOP(I2) C IF(ICASRE.EQ.'FUNC')GOTO4370 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4341) 4341 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4342) 4342 FORMAT(' A NAME IN THE LIST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4343) 4343 FORMAT(' OF FUNCTIONS (= STRINGS) TO BE READ ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4344) 4344 FORMAT(' INCLUDED THE NAME OF A ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4345) 4345 FORMAT(' PREVIOUSLY-DEFINED VARIABLE OR PARAMETER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4346)IH1,IH2 4346 FORMAT(' THE NAME OF THE VARIABLE OR PARAMETER WAS ', 1 2A4,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4347) 4347 FORMAT(' NO READ WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C ENDIF ENDIF 4300 CONTINUE C ICASEA='U' IU=IU+1 IF(IU.GT.MAXU2)GOTO4370 JUNAM1(IU)=IH1 JUNAM2(IU)=IH2 GOTO4370 C 4370 CONTINUE IE=IE+1 IF(IE.GT.MAXE2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4381) 4381 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4382) 4382 FORMAT(' THE NUMBER OF NAMES IN THE READ COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4383) 4383 FORMAT(' HAS JUST EXCEEDED THE ALLOWABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4384)MAXE2 4384 FORMAT(' MAXIMUM (',I5,')') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 ENDIF C JENAM1(IE)=IH1 JENAM2(IE)=IH2 IECASE(IE)='NEW' IF(ICASEA.EQ.'V')IECASE(IE)='OLD' IECOL2(IE)=-1 IF(ICASEA.EQ.'V')IECOL2(IE)=IVALUE(I2) IF(ICASEA.EQ.'P')IECASE(IE)='OLD' IF(ICASEA.EQ.'F')IECASE(IE)='OLD' C IF(ICASTO.EQ.'ON')GOTO4215 C 4200 CONTINUE 4290 CONTINUE C CCCCC FEBRUARY 2003: IF NO VARIABLES GIVEN, THEN WILL CCCCC DETERMINE AUTOMATICALLY LATER ON. C NUMV=IV NUMP=IP NUMM=IM NUMF=IF NUMU=IU NUME=IE C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,4411)NUMALL,NUMV,NUMP,NUMM,NUMF,NUMU,NUME 4411 FORMAT('NUMALL,NUMV,NUMP,NUMM,NUMF,NUMU,NUME = ',7I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4412) 4412 FORMAT('I,JVNAM1(I),JVNAM2(I),JPNAM1(I),JPNAM2(I), 1 JMNAM1(I),JMNAM2(I),JFNAM1(I),JFNAM2(I),JUNAM1(I),JUNAM2(I)') CALL DPWRST('XXX','BUG ') DO4420I=1,15 WRITE(ICOUT,4421)I,JVNAM1(I),JVNAM2(I),JPNAM1(I),JPNAM2(I), 1 JMNAM1(I),JMNAM2(I),JFNAM1(I),JFNAM2(I),JUNAM1(I),JUNAM2(I) 4421 FORMAT(I8,5X,2A4,1X,2A4,1X,2A4,1X,2A4,1X,2A4) CALL DPWRST('XXX','BUG ') 4420 CONTINUE ENDIF C C *************************************************** C ** STEP 5-- ** C ** CHECK FOR A VALID NUMBER ** C ** (1 TO 100) OF VARIABLES TO BE READ ** C ** (NOTE--THIS DOES NOT INCLUDE PARAMETERS ** C ** OR MODELS IN THE ABOVE COUNT-- ** C ** ONLY VARIABLES.) ** C ** CHECK FOR A VALID NUMBER ** C ** (0 TO 100) OF CONSTANTS TO BE READ . ** C ** CHECK FOR A VALID NUMBER ** C ** (0 TO 100) OF MODELS TO BE READ . ** C ** CHECK FOR A VALID NUMBER ** C ** (0 TO 100) OF FUNCTIONS TO BE READ . ** C ** CHECK FOR A VALID NUMBER ** C ** (1 TO 100) OF UNKNOWNS TO BE READ . ** C *************************************************** C IF(NUMV.LT.0 .OR. NUMV.GT.MAXV2)THEN C WRITE(ICOUT,511) 511 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,512) 512 FORMAT(' FOR A READ, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,513) 513 FORMAT(' THE NUMBER OF VARIABLES (NOT COUNTING ', 1 'PARAMETERS OR MODELS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,514)MAXV2 514 FORMAT(' MUST BE AT MOST ',I8,' ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,515) 515 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,516) 516 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,517)NUMV 517 FORMAT(' OF VARIABLES TO BE READ WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,518)MAXV2 518 FORMAT(' NOTE--ONLY THE FIRST ',I8,' VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,519) 519 FORMAT(' WILL BE READ .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,520) 520 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,521)(IANSLC(I),I=1,MIN(80,IWIDTH)) 521 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF ENDIF C IF(NUMP.LT.0 .OR. NUMP.GT.MAXP2)THEN C WRITE(ICOUT,531) 531 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,532) 532 FORMAT(' FOR A READ, THE NUMBER OF PARAMETERS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,534)MAXP2 534 FORMAT(' (CONSTANTS) MUST BE AT MOST ',I8,' ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,535) 535 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,537)NUMP 537 FORMAT(' NUMBER OF PARAMETERS TO BE READ WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,538)MAXP2 538 FORMAT(' NOTE--ONLY THE FIRST ',I8,' PARAMETERS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,539) 539 FORMAT(' WILL BE READ .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,540) 540 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,541)(IANSLC(I),I=1,MIN(80,IWIDTH)) 541 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF ENDIF C IF(NUMM.LT.0 .OR. NUMM.GT.MAXM2)THEN C WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553) 553 FORMAT(' FOR A READ, THE NUMBER OF MODELS MUST BE AT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555)MAXM2 555 FORMAT(' MOST ',I8,' ; SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556)NUMM 556 FORMAT(' THE SPECIFIED NUMBER OF MODELS TO BE READ WAS ', 1 I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558)MAXM2 558 FORMAT(' NOTE--ONLY THE FIRST ',I8,' MODELS WILL BE ', 1 'READ.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 560 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,561)(IANSLC(I),I=1,MIN(80,IWIDTH)) 561 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF ENDIF C IF(NUMF.LT.0 .OR. NUMM.GT.MAXF2)THEN C WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A READ, THE NUMBER OF FUNCTIONS MUST BE AT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,575)MAXF2 575 FORMAT(' MOST ',I8,' ; SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576)NUMF 576 FORMAT(' THE SPECIFIED NUMBER OF FUNCTIONS TO BE READ ', 1 'WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578)MAXF2 578 FORMAT(' NOTE--ONLY THE FIRST ',I8,' FUNCTIONS WILL BE ', 1 'READ.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 580 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,581)(IANSLC(I),I=1,MIN(80,IWIDTH)) 581 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF ENDIF C IF(NUMU.LT.0 .OR. NUMU.GT.MAXU2)THEN C WRITE(ICOUT,611) 611 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,612) 612 FORMAT(' FOR A READ, THE NUMBER OF UNKNOWNS MUST BE AT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,614)MAXU2 614 FORMAT(' MUST BE AT MOST ',I8,'; SUCH WAS NOT THE CASE ', 1 'HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,617)NUMU 617 FORMAT(' THE SPECIFIED NUMBER OF UNKNOWNS TO BE READ WAS ', 1 I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,618)MAXU2 618 FORMAT(' NOTE--ONLY THE FIRST ',I8,' UNKNOWNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,619) 619 FORMAT(' WILL BE READ .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,620) 620 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,621)(IANSLC(I),I=1,MIN(80,IWIDTH)) 621 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF C ENDIF C IF(ICASRE.NE.'ROWI' .AND. NUME.LT.1 .AND. ICNTCH.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4451) 4451 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4452) 4452 FORMAT(' NO VARIABLE NAMES WERE PROVIDED IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4453) 4453 FORMAT(' READ STATEMENT, HENCE NO READ WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4454) 4454 FORMAT(' ILLUSTRATIVE EXAMPLE TO DEMONSTRATE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4455) 4455 FORMAT(' THE PROPER FORM FOR THE READ COMMAND--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4456) 4456 FORMAT(' SUPPOSE THE ANALYST WISHES TO READ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4457) 4457 FORMAT(' DATA FROM THE FILE CALIB.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4458) 4458 FORMAT(' INTO THE INTERNAL VARIABLES Y, X1, AND X2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4459) 4459 FORMAT(' THIS IS DONE BY ENTERING THE COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4460) 4460 FORMAT(' READ CALIB. Y X1 X2') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 ENDIF C C ******************************************************* C ** STEP 6-- ** C ** THOSE NAMES WHICH ARE OF THE UNKNOWN CATEGORY ** C ** WILL BECOME FUTURE VARIABLES/PARAMETERS/FUNCTIONS.* C ** ASSIGN THESE VARIABLES TO THE NEXT AVAILABLE ** C ** COLUMNS, AND UPDATE THE NAME TABLE ACCORDINGLY. ** C ******************************************************* C IF(NUME.GT.0)THEN INAM=NUMNAM IF(ICASRE.EQ.'VARI')ICOL=NUMCOL DO700IE=1,NUME IF(ICASRE.EQ.'VARI'.AND.IECASE(IE).EQ.'OLD')GOTO700 IF(ICASRE.EQ.'PARA'.AND.IECASE(IE).EQ.'OLD')GOTO700 IF(ICASRE.EQ.'FUNC'.AND.IECASE(IE).EQ.'OLD')GOTO700 IF(ICASRE.EQ.'MATR'.AND.IECASE(IE).EQ.'OLD')GOTO700 IF(ICASRE.EQ.'VARI'.AND.IECOL2(IE).GE.1)GOTO700 IF(ICASRE.EQ.'MATR')GOTO700 INAM=INAM+1 IF(ICASRE.EQ.'VARI')ICOL=ICOL+1 C IF(INAM.GT.MAXNAM)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,711) 711 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,712) 712 FORMAT(' THE NUMBER OF NAMES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,713) 713 FORMAT(' (VARIABLES + PARAMETERS + FUNCTIONS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,714) 714 FORMAT(' HAS JUST EXCEEDED THE MAXIMUM SIZE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,715)MAXNAM 715 FORMAT(' (',I5,') OF THE INTERNAL NAME TABLE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 ENDIF C IF(ICASRE.NE.'PARA' .AND. ICASRE.NE.'FUNC' .AND. 1 ICASRE.NE.'ROWI' .AND. ICOL.GT.MAXCOL)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,721) 721 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,722) 722 FORMAT(' THE NUMBER OF COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,723) 723 FORMAT(' IN THE INTERNAL DATAPLOT DATA ARRAY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,724) 724 FORMAT(' HAS JUST EXCEEDED THE ALLOWABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,725)MAXCOL 725 FORMAT(' MAXIMUM (',I5,')') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 ENDIF C IHNAME(INAM)=JENAM1(IE) IHNAM2(INAM)=JENAM2(IE) IF(ICASRE.EQ.'PARA')IUSE(INAM)='P' IF(ICASRE.EQ.'FUNC')IUSE(INAM)='F' IF(ICASRE.EQ.'VARI')THEN IUSE(INAM)='V' IVALUE(INAM)=ICOL IECOL2(IE)=ICOL IN(INAM)=0 ENDIF 700 CONTINUE NUMNAM=INAM IF(ICASRE.EQ.'VARI')NUMCOL=ICOL ENDIF C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,791)NUMNAM,NUMCOL,NUMNAM,ICASRE 791 FORMAT('NUMNAM,NUMCOL,NUMNAM,ICASRE = ',3I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C ******************************************************** C ** STEP 7-- ** C ** FIRST, BRANCH TO THE APPROPRIATE SUBCASE ** C ** (DEPENDING ON WHETHER UNQUALIFIED, SUBSET OR FOR);** C ** THE DETERMINE THE LENGTH OF THE LONGEST ** C ** VARIABLE TO BE READ IN ; ** C ** THEN READ IN THE VARIABLES ** C ** THAT WERE SPECIFIED. ** C ******************************************************** C ISTEPN='7' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MAXNRD=MAXN IF(IREASB.EQ.'P-P ')ICASEQ='FULL' IF(ICASEQ.EQ.'FULL')THEN DO7315I=1,MAXNRD ISUB(I)=1 7315 CONTINUE NQ2=MAXNRD ELSEIF(ICASEQ.EQ.'SUBS')THEN NIOLD=MAXNRD CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ2=NIOLD ELSEIF(ICASEQ.EQ.'FOR')THEN NIOLD=MAXNRD CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1 NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ2=NFOR ENDIF C C ******************************************* C ** STEP 8-- ** C ** IF A DATA ROW MINIMUM EXISTS AND SO ** C ** OUR ATTENTION IS FOCUSED ONLY ON ** C ** CERTAIN ROWS OF THE DATA FILE, ** C ** THEN GO DOWN TO THE FIRST SUCH ROW ** C ** IN THE FILE. ** C ******************************************* C ISTEPN='8' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFMFLG.EQ.'ON' .OR. IFROW1.LE.1)GOTO7369 IFRMIN=1 IFRMAX=IFROW1-1 IF(IFRMIN.GT.IFRMAX)GOTO7369 MINCO2=1 MAXCO2=NUMRCM IF(IRD2.EQ.IRD)MAXCO2=80 IFCOL3=IFCOL1 IFCOL4=IFCOL2 C THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1988 C TO "TURN OFF" THE COLUMN LIMITS IF READING FROM A NON-FILE C (THAT IS, IF READING FROM THE TERMINAL OR WITHIN A MACRO). IF(IOFILE.EQ.'NO')THEN IFCOL3=MINCO2 IFCOL4=MAXCO2 ENDIF IF(IRD2.EQ.IRD.AND.IFCOL4.GT.MAXCO2)IFCOL4=MAXCO2 C DO7360IFROW=IFRMIN,IFRMAX IF(IOFILE.EQ.'NO')THEN READ(IRD2,7361,END=7363,ERR=7363)IJUNK 7361 FORMAT(A1) ELSEIF(IOFILE.EQ.'YES')THEN NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA, 1 ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO8800 IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND. 1 NUMCHA.EQ.3)GOTO7363 ENDIF GOTO7360 C 7363 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7364) 7364 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7365) 7365 FORMAT(' END OF FILE ENCOUNTERED WHILE SKIPPING OVER', 1 'HEADER LINES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7367) 7367 FORMAT(' NOTE SKIP AND ROW LIMITS SETTINGS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7368)ISKIP,IFROW1,AFROW2 7368 FORMAT(' ISKIP,IFROW1,IFROW2 = ',2I8,2X,E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C 7360 CONTINUE 7369 CONTINUE C C ******************************************* C ** STEP 9-- ** C ** IN ADDITION, IF HEADER (= NON-DATA) ** C ** LINES EXIST WHICH ARE TO BE SKIPPED ** C ** OVER IN THE READ, DO SO HERE. ** C ******************************************* C ISTEPN='9' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFMFLG.EQ.'ON' .OR. IOFILE.EQ.'NO')GOTO7389 C IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IF(IFROW1.LE.1)THEN WRITE(ICOUT,7371) 7371 FORMAT('THE NUMBER OF HEADER LINES') CALL DPWRST('XXX','BUG ') ELSEIF(IFROW1.GE.2)THEN WRITE(ICOUT,7372) 7372 FORMAT('THE NUMBER OF (ADDITIONAL) HEADER LINES') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,7373)ISKIP 7373 FORMAT(' BEING SKIPPED = ',I6) CALL DPWRST('XXX','BUG ') ENDIF C CCCCC OCTOBER 1997. SUPPORT "SKIP AUTOMATIC", DENOTED BY ISKIP = -1. CCCCC READ UNTIL FIND "----". IF "----" IS NOT FOUND, REWIND THE CCCCC FILE, AND START READ FROM LINE 1. ALSO, IF READING FROM CCCCC THE TERMINAL, THEN THIS OPTION DOESN'T MAKE SENSE, SO CCCCC ASSUME ISKIP = 0 IN THIS CASE. C IF(ISKIP.EQ.-1.AND.IOFILE.EQ.'YES')THEN IFRMIN=1 MINCO2=1 MAXCO2=NUMRCM IF(IRD2.EQ.IRD)MAXCO2=80 IFCOL3=IFCOL1 IFCOL4=IFCOL2 IF(IRD2.EQ.IRD.AND.IFCOL4.GT.MAXCO2)IFCOL4=MAXCO2 DO7378I=1,50000 NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) C IF(IERROR.EQ.'YES')GOTO8800 IF(IA(1).EQ.'-'.AND.IA(2).EQ.'-'.AND.IA(3).EQ.'-'.AND. 1 IA(4).EQ.'-')THEN GOTO7389 ENDIF IF(NUMCHA.GE.5)THEN DO7379LL=1,NUMCHA-3 IF(IA(LL).EQ.'-'.AND.IA(LL+1).EQ.'-'.AND. 1 IA(LL+2).EQ.'-'.AND.IA(LL+3).EQ.'-')THEN GOTO7389 ENDIF 7379 CONTINUE ENDIF IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND. 1 NUMCHA.EQ.3)THEN REWIND IOUNIT GOTO7389 ENDIF 7378 CONTINUE ENDIF C IF(ISKIP.LE.0)GOTO7389 IFRMIN=IFROW1 IFRMAX=IFROW1+ISKIP-1 IF(IFRMIN.GT.IFRMAX)GOTO7389 MINCO2=1 MAXCO2=NUMRCM IF(IRD2.EQ.IRD)MAXCO2=80 IFCOL3=IFCOL1 IFCOL4=IFCOL2 C THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1988 C TO "TURN OFF" THE COLUMN LIMITS IF READING FROM A NON-FILE C (THAT IS, IF READING FROM THE TERMINAL OR WITHIN A MACRO). IF(IOFILE.EQ.'NO')THEN IFCOL3=MINCO2 IFCOL4=MAXCO2 ENDIF IF(IRD2.EQ.IRD.AND.IFCOL4.GT.MAXCO2)IFCOL4=MAXCO2 DO7380IFROW=IFRMIN,IFRMAX IF(IOFILE.EQ.'NO')THEN READ(IRD2,7382,END=7383)IJUNK 7382 FORMAT(A1) ELSEIF(IOFILE.EQ.'YES')THEN NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA, 1 ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO8800 IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND. 1 NUMCHA.EQ.3)GOTO7383 ENDIF GOTO7380 C 7383 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7384) 7384 FORMAT('***** ERROR IN DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7385) 7385 FORMAT(' END OF FILE ENCOUNTERED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7386) 7386 FORMAT(' WHILE SKIPPING OVER HEADER LINES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7387) 7387 FORMAT(' NOTE SKIP AND ROW LIMITS SETTINGS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7388)ISKIP,IFROW1,AFROW2 7388 FORMAT(' ISKIP,IFROW1,AFROW2 = ',2I8,2X,E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C 7380 CONTINUE 7389 CONTINUE C C ************************ C ** STEP 10-- ** C ** READ IN THE DATA ** C ************************ C ISTEPN='10' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7210)NUME 7210 FORMAT('NUME = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7211)IRD,IRD2 7211 FORMAT('IRD,IRD2 = ',I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C DO7260I=1,MAXRCL ISTOR1(I)=' ' ISTOR2(I)=' ' ISTOR3(I)=' ' IB(I)=' ' 7260 CONTINUE C IF(NUME.GT.0)THEN DO7300I=1,NUME IEN(I)=0 7300 CONTINUE ENDIF C MINCO2=1 MAXCO2=NUMRCM IF(IRD2.EQ.IRD)MAXCO2=80 IFCOL3=IFCOL1 IFCOL4=IFCOL2 C THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1988 C TO "TURN OFF" THE COLUMN LIMITS IF READING FROM A NON-FILE C (THAT IS, IF READING FROM THE TERMINAL OR WITHIN A MACRO). IF(IOFILE.EQ.'NO')THEN IFCOL3=MINCO2 IFCOL4=MAXCO2 ENDIF IF(IRD2.EQ.IRD.AND.IFCOL4.GT.MAXCO2)IFCOL4=MAXCO2 C I=0 IIN=0 NUMLRD=0 IENDTY=1 CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1990 CCCCC TO FIX FORMATTED READ YIELDING ONLY 1 LINE JUNE 1990 IEND='NO' IF(ISKIP.GE.0)THEN IFRMIN=IFROW1+ISKIP IF(ICASEQ.EQ.'FOR')IFRMIN=IFROW1+ISKIP+IROW1-1 ELSE IFRMIN=1 IF(ICASEQ.EQ.'FOR')IFRMIN=IROW1 ENDIF C CCCCC OCTOBER 2004: ACCOUNT FOR SUBSET/FOR CLAUSE LIMITS C IFRMAX=IFROW2 IF(ICASEQ.EQ.'FOR')THEN IFRMAX=MIN(IFROW2,IROWN) ENDIF C IF(ICASRE.EQ.'PARA' .OR. ICASRE.EQ.'FUNC')IFRMAX=IFRMIN IF(IHOST1.EQ.'CDC'.AND.IFRMAX.GT.130000)IFRMAX=130000 IF(IFRMAX.GE.IBILLI)IFRMAX=IBILLI IF(IFRMIN.GT.IFRMAX)GOTO7470 CCCCC APRIL 1995. CHECK FOR UNFORMATTED READ CASE. CCCCC INITIAL IMPLEMENTATION ONLY APPLIES TO VARIABLES (NOT CCCCC STRINGS, FUNCTIONS, MATRICES). CCCCC 1) THE FOLLOWING COMMAND: CCCCC SET UNFORMATTED COLUMNS CCCCC SPECIFIES THE NUMBER OF COLUMNS WHEN READING A MATRIX CCCCC 2) UNFORMATTED READ ASSUMES A "SQUARE MATRIX" OF NUMBERS CCCCC CONTAINING ONLY REAL NUMBERS WAS WRITTEN (THAT IS, ASSUME CCCCC A SINGLE WRITE PERFORMED, NOT A MIXTURE OF DIFFERENT TYPES CCCCC ETC.). THE FOLLOWING 2 COMMANDS PROVIDE A LIMITED AMOUNT CCCCC OF FLEXIBILITY: CCCCC SET UNFORMATTED OFFSET CCCCC SET UNFORMATTED RECORDS CCCCC THE FIRST COMMAND SPECIFIES THE NUMBER OF DATA VALUES TO CCCCC SKIP AT THE BEGINING OF THE FILE. THE SECOND COMMAND CCCCC SPECIFIES THE NUMBER OF DATA VALUES TO READ. CCCCC 3) THERE ARE ESSENTIALLY 2 WAYS TO CREATE THE UNFORMATTED CCCCC FILE. FOR EXAMPLE, ASSUME WRITING 10,000 ROWS OF VARIABLES CCCCC X AND Y. THEN CAN WRITE AS: CCCCC A) WRITE(IUNIT) X,Y CCCCC B) WRITE(IUNIT) (X(I),Y(I),I=1,N) CCCCC THE DISTINCTION IS THAT (A) WRITES ALL OF X AND THEN ALL OF CCCCC Y WHEREAS (B) WRITES X(1), Y(1), X(2), Y(2), ..., X(N), Y(N). CCCCC INITIAL IMPLEMENTATION ASSUMES (B) SINCE THIS CORRESPONDS CCCCC TO DATAPLOT'S STORING BY COLUMN. THE CCCCC "SET READ UNFORMATTED-COLUMNWISE" COMMAND SPECIFIES THAT CCCCC METHOD (A) WAS USED TO CREATE THE FILE. CCCCC DATAPLOT WILL READ ENTIRE UNFORMATTED FILE INTO "XSCRT" CCCCC ARRAY. IT WILL CHECK HOW MANY DATA VALUES WERE READ. IT THEN CCCCC DIVIDES THIS BY NUMBER OF VARIABLES TO BE READ. THE DO7400 CCCCC LOOP BELOW THEN EXTRACTS EACH ROW OF DATA FROM THIS XSCRT CCCCC ARRAY. C IF(IFMFLG.EQ.'ON')THEN C IF(IUNFOF.GT.2*MAXOBV)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11212)IUNFOF,2*MAXOBW 11212 FORMAT('****** ERROR: OFFSET OF ',I8,' IS GREATER THAN ', 1 'MAXIMUM ALLOWED OF ',I8) CALL DPWRST('XXX','BUG ') ENDIF C DO11002JJ=1,3*MAXOBW XSCRT(JJ)=CPUMIN 11002 CONTINUE C IF(ICASRE.EQ.'MATR')NUME=IUNFMC C CCCCC JULY 1996. SGI DOESN'T READ IF XSCRT DIMENSIONED BIGGER CCCCC THAN NUMBER OF DATA POINTS IN FILE. USER MAY NEED TO SPECIFY CCCCC THE COMMAND "SET UNFORMATTED RECORDS ". C IF(IUNFNR.GT.0)THEN READ(IRD2,ERR=11080,END=11090,IOSTAT=JSTATS) 1 (XSCRT(LL),LL=1,IUNFNR+IUNFOF) ELSE READ(IRD2,ERR=11080,END=11090,IOSTAT=JSTATS)XSCRT ENDIF GOTO11090 C 11080 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11081)JSTATS 11081 FORMAT('****** ERROR TRYING TO READ AN UNFORMATTED FILE, ', 1 'STATUS NUMBER = ',I8,'.') CALL DPWRST('XXX','BUG ') GOTO11090 C 11090 CONTINUE NSTOP=MAXOBW+IUNFOF IF(IUNFNR.GT.0)NSTOP=IUNFNR+IUNFOF DO11100JJ=NSTOP,1,-1 NPTS=JJ IF(XSCRT(JJ).NE.CPUMIN)GOTO11109 11100 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11111) 11111 FORMAT('****** ERROR: NO DATA FOUND IN THE UNFORMATTED FILE.') CALL DPWRST('XXX','BUG ') GOTO9000 11109 CONTINUE NPTS=NPTS-IUNFOF IFRMIN=1 IFRMAX=NPTS/NUME ENDIF C IF(ICASRE.EQ.'ROWI')THEN DO17411II=1,MAXOBV IROWLB(II)=' ' 17411 CONTINUE ENDIF C CCCCC OCTOBER 2004: SUBSET/FOR/EXPECT CLAUSES ON READ HAVE SOME CCCCC AMBIGUITY. THAT IS, DOES THE SUBSET REFER TO THE LINES THAT CCCCC ARE READ FROM THE FILE OR DOES THE SUBSET REFER TO HOW THE CCCCC DATA ARE SAVED IN THE OUTPUT VECTORS. WE ADDRESS THIS WITH CCCCC THE COMMAND CCCCC CCCCC SET READ SUBSET CCCCC CCCCC THE FIRST SETTING SPECIFIES HOW THE DATA FILE IS HANDLED CCCCC (PACK MEANS SUBSET/FOR CLAUSE DOES NOT APPLY TO LINES IN CCCCC FILE WHILE DISPERSE MEANS THAT IT DOES). LIKEWISE, THE SECOND CCCCC SETTING SPECIFIES HOW THE SUBSET/FOR CLAUSE APPLIES TO THE CCCCC OUTPUT VARIABLES (PACK MEANS SUBSET IGNORED ON OUTPUT VECTOR, CCCCC DISPERSE MEAMS THAT IT DOES). THESE SETTINGS ARE CODED AS CCCCC "P-D", "P-P", "D-P", "D-D". THE DEFAULT IS "P-D" (I.E., CCCCC THE SUBSET APPLIES TO THE OUTPUT VECTORS, BUT NOT THE INPUT CCCCC FILE). FOR EXAMPLE, THE COMMAND CCCCC CCCCC READ X FOR I = 1 2 10 CCCCC CCCCC X P-D P-P D-P D-D CCCCC =========================================== CCCCC 1 1 1 1 1 CCCCC 2 0 2 3 0 CCCCC 3 2 3 5 3 CCCCC 4 0 4 7 0 CCCCC 5 3 5 9 5 CCCCC 6 0 - - 0 CCCCC 7 4 - - 7 CCCCC 8 0 - - 0 CCCCC 9 5 - - 9 CCCCC 10 0 - - 0 C NCALL=0 IMAXRW=IFRMAX-IFRMIN+1 DO7400IFROW=IFRMIN,IFRMAX C IIN=IIN+1 IF(ISUB(IIN).NE.1)THEN IF(IREASB(1:1).EQ.'D')THEN IF(IREASB(3:3).EQ.'D')THEN I=I+1 ENDIF NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND. 1 NUMCHA.EQ.3)THEN REWIND IOUNIT IENDTY=1 GOTO7490 ENDIF GOTO7400 ENDIF ENDIF C IF(NCREAF.LE.0 .OR. ICASRE.EQ.'FUNC' .OR. ICASRE.EQ.'ROWI')THEN CALL DPREAL(IRD2,IFCOL3,IFCOL4,MINCO2,MAXCO2,X0,NUMDPL, 1 IXC,NXC, 1 ICASRE,IFUNC2,N2,MAXN2, 1 IMACRO,IMACNU,IMACCS, 1 IANSLC,IWIDTH,IREACS,ISTOR1,ISTOR2,IEND,NUMLRD, 1 IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 ICOMCH,ICOMSW,LINETY,IGRPA2, 1 IFCOLL,IFCOLU,ITYPE,NCOLS,NCALL,IREADL,PREAMV, 1 MAXRDV,MAXCHV, 1 IDECPT, 1 IB, 1 IERRFI,IBUGS2,ISUBRO,IERROR) IF(LINETY.EQ.'BLAN')GOTO7400 NUMLRD=NUMLRD+1 NCALL=NCALL+1 C C IF CHARACTER DATA ENCOUNTERED, WRITE IT TO FILE C IF(NXC.GT.0 .AND. IGRPAU.EQ.'CHAR')THEN IF(NUMLRD.EQ.1)THEN C IOUNI2=IZCHNU IFILE2=IZCHNA ISTAT2=IZCHST IFORM2=IZCHFO IACCE2=IZCHAC IPROT2=IZCHPR ICURS2=IZCHCS C ISUBN0='READ' IERRFI='NO' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2, 1 ICURS2, 1 IREWI2,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 IZCHCS=ICURS2 C WRITE(IOUNI2,'(I8)')NXC DO27810ICNT=1,MIN(ICNTCH,MAXCHV) WRITE(IOUNI2,'(A4,A4)')ICLIST(ICNT),ICLIS2(ICNT) 27810 CONTINUE ENDIF WRITE(IOUNI2,'(20(A24,1X))')(IXC(J)(1:24),J=1,NXC) ENDIF ELSEIF(IFMFLG.EQ.'ON')THEN C NUMLRD=NUMLRD+1 IF(IUNFNR.GT.0.AND.NUMLRD*NUME.GT.IUNFNR)GOTO7400 NUMDPL=NUME IF(ICRFLG.EQ.'ROW')THEN IPTR1=(NUMLRD-1)*NUME+1+IUNFOF IPTR2=IPTR1+NUME-1 ICOUNT=0 DO17415JJ=IPTR1,IPTR2 ICOUNT=ICOUNT+1 X0(ICOUNT)=XSCRT(JJ) 17415 CONTINUE ELSE IPTR1=NUMLRD+IUNFOF IPTR2=IFRMAX DO17515JJ=1,NUME ICOUNT=IPTR1+(JJ-1)*IPTR2 X0(JJ)=XSCRT(ICOUNT) 17515 CONTINUE ENDIF ELSE NUMLRD=NUMLRD+1 NUMDPL=NUME IF(ICOMSW.EQ.'ON')THEN 7417 CONTINUE READ(IRD2,'(A80)',END=7480)IAJUNK IF(IAJUNK(1:1).EQ.ICOMCH(1:1))GOTO7417 BACKSPACE(UNIT=IRD2,IOSTAT=IOS,ERR=7413) GOTO7415 7413 CONTINUE WRITE(ICOUT,743) 743 FORMAT('ERROR TRYING TO BACKSPACE FILE ON FORMATTED READ') CALL DPWRST('XXX','BUG ') GOTO7417 ENDIF READ(IRD2,ICREAF,END=7480,ERR=7480)(X0(K),K=1,NUME) GOTO7415 ENDIF C 7415 CONTINUE IF(IERROR.EQ.'YES')GOTO8800 IF(IFROW.EQ.IFRMIN)THEN DO7425K=1,132 ISTOR3(K)=ISTOR2(K) 7425 CONTINUE GOTO7430 ENDIF IF(IEND.EQ.'YES')GOTO7480 C 7430 CONTINUE I=I+1 C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7431) 7431 FORMAT('***** FROM THE MIDDLE OF DPREAD--') CALL DPWRST('XXX','BUG ') AFRMAX=IFRMAX WRITE(ICOUT,7432)IFROW,IFRMIN,AFRMAX,IBUGS2,ISUBRO 7432 FORMAT('IFROW,IFRMIN,AFRMAX,IBUGS2,ISUBRO = ',2I8,E15.7, 1 2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7433)I,ISUB(I),NUME,IBUGS2,ISUBRO 7433 FORMAT('I,ISUB(I),NUME,IBUGS2,ISUBRO = ',3I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7434)MAXN,MAXCOL,MAXCP1,MAXCP2 7434 FORMAT('MAXN,MAXCOL,MAXCP1,MAXCP2 = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7435)X0(1),X0(2),X0(3) 7435 FORMAT('X0(1),X0(2),X0(3) = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7436)IECOL2(1),IECOL2(2),IECOL2(3) 7436 FORMAT('IECOL2(1),IECOL2(2),IECOL2(3) = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7437)IEN(1),IEN(2),IEN(3) 7437 FORMAT('IEN(1),IEN(2),IEN(3) = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7438)ICASRE,NUMVRD,NUMPRD,NUMFRD 7438 FORMAT('ICASRE,NUMVRD,NUMPRD,NUMFRD = ',A4,3I8) CALL DPWRST('XXX','BUG ') ENDIF C CCCCC OCTOBER 2004: IS OUTPUT VECTOR PACKED OR DISPERSED? C IF(I.GT.MAXN .OR. I.GT.IMAXRW)GOTO7480 IJUNK=I IF(IREASB(3:3).EQ.'P' .AND. IREASB(1:1).EQ.'D')IJUNK=IIN IF(ISUB(IJUNK).EQ.1)THEN GOTO7440 ELSE IF(IREASB(3:3).EQ.'D')THEN GOTO7430 ELSE GOTO7400 ENDIF ENDIF C 7440 CONTINUE IF(ICASRE.EQ.'PARA')THEN NUMPRD=NUME GOTO7400 ELSEIF(ICASRE.EQ.'FUNC')THEN NUMFRD=NUME GOTO7400 ELSEIF(ICASRE.EQ.'MATR')THEN C C -----BEGIN MATRIX COPY----- C IHMAT1 = FIRST HALF OF MATRIX NAME C IHMAT2 = SECOND HALF OF MATRIX NAME C INAMMA = NAME INDEX FOR MATRIX C IMATC1 = FIRST COLUMN OF THE MATRIX C IMATNR = NUMBER OF ROWS IN THE MATRIX C IMATNC = NUMBER OF COLUMNS IN THE NATRIX C IF(NUMLRD.EQ.1)THEN C INAM=NUMNAM ICOL=NUMCOL C INAM=INAM+1 ICOL=ICOL+1 C INAMMA=INAM IMATC1=ICOL C IHNAME(INAMMA)=IHMAT1 IHNAM2(INAMMA)=IHMAT2 IUSE(INAMMA)='M' IVALUE(INAMMA)=ICOL IN(INAMMA)=0 IVALU2(INAMMA)=ICOL+NUMDPL-1 IMATNC=NUMDPL NUMNAM=INAM NUMCOL=ICOL C ICOL=ICOL-1 IF(NUMDPL.GT.0)THEN DO7452IE=1,NUMDPL INAM=INAM+1 ICOL=ICOL+1 IHNAME(INAM)=JENAM1(IE) IHNAM2(INAM)=JENAM2(IE) IUSE(INAM)='V' IVALUE(INAM)=ICOL IN(INAM)=0 IECOL2(IE)=ICOL IF(IBUGS2.EQ.'ON')THEN WRITE(ICOUT,7453)IE,IECOL2(IE),NUMDPL,INAM,NUMNAM 7453 FORMAT('IE,IECOL2(IE),NUMDPL,INAM,NUMNAM = ',5I8) CALL DPWRST('XXX','BUG ') ENDIF 7452 CONTINUE NUMNAM=INAM NUMCOL=ICOL ENDIF ENDIF C IE2=0 IMATNR=0 IF(NUMDPL.GT.0)THEN DO7455IE=1,NUMDPL IE2=IE Z0=X0(IE) IF(IBUGS2.EQ.'ON')THEN WRITE(ICOUT,7456)IE,IECOL2(IE),NUMDPL,INAM,NUMNAM 7456 FORMAT('IE,IECOL2(IE),NUMDPL,INAM,NUMNAM = ',5I8) CALL DPWRST('XXX','BUG ') ENDIF ICOLVJ=IECOL2(IE) IJ=MAXN*(ICOLVJ-1)+I IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0 IF(ICOLVJ.EQ.MAXCP1)PRED(I)=Z0 IF(ICOLVJ.EQ.MAXCP2)RES(I)=Z0 IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=Z0 IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=Z0 IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=Z0 IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=Z0 IEN(IE)=I IN(INAM)=I IN(INAMMA)=I IMATNR=I 7455 CONTINUE NUMVRD=IE2 GOTO7400 ENDIF NUMVRD=IE2-1 GOTO7400 C C -----END MATRIX COPY----- C ELSEIF(ICASRE.EQ.'ROWI')THEN IF(I.GT.MAXN)GOTO7480 IROWLB(I)=' ' IF(ISUB(I).NE.1)GOTO7400 ILEN=24 IF(N2.LT.ILEN)ILEN=N2 DO7442KK=1,ILEN IROWLB(I)(KK:KK)=IFUNC2(KK)(1:1) 7442 CONTINUE GOTO7400 ENDIF C C OCTOBER 2004. IF NUMBER OF REQUESTED ITEMS IS GREATER THAN C NUMBER OF ITEMS ON THE LINE, PAD WITH MISSING C VALUE (PREAMV). C C THE SET READ PAD MISSING COLUMNS COMMANDS C DETERMINES WHETHER WE PAD OR USE THE PREVIOUS C BEHAVIOR (I.E., IN SOME CASES, A MISSING COLUMN C MAY INDICATE AN ERROR). C IE2=0 IF(NUME.LE.0)GOTO7448 DO7445IE=1,NUME IE2=IE CCCCCC IF(IE2.GT.NUMDPL)GOTO7448 IF(IREAPD.EQ.'OFF')THEN IF(IE2.GT.NUMDPL)GOTO7448 Z0=X0(IE) ELSE IF(IE2.GT.NUMDPL)THEN Z0=PREAMV ELSE Z0=X0(IE) ENDIF ENDIF ICOLVJ=IECOL2(IE) IJ=MAXN*(ICOLVJ-1)+I IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0 IF(ICOLVJ.EQ.MAXCP1)PRED(I)=Z0 IF(ICOLVJ.EQ.MAXCP2)RES(I)=Z0 IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=Z0 IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=Z0 IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=Z0 IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=Z0 IEN(IE)=I 7445 CONTINUE NUMVRD=IE2 GOTO7400 7448 CONTINUE NUMVRD=IE2-1 7400 CONTINUE 7470 CONTINUE IENDTY=2 GOTO7490 C 7480 CONTINUE IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,7481)NUME 7481 FORMAT('AT 7480: ERROR OR END OF FILE FOR FORMATTED READ, ', 1 'NUME = ',I8,'.') CALL DPWRST('XXX','BUG ') DO7485K=1,NUME WRITE(ICOUT,7487)X0(K) 7487 FORMAT('K, X0(K) = ',I8,2X,G15.7) CALL DPWRST('XXX','BUG ') 7485 CONTINUE ENDIF IENDTY=1 NUMLRD=NUMLRD-1 GOTO7490 C 7490 CONTINUE C C ***************************** C ** STEP 11-- ** C ** UPDATE THE NAME TABLE ** C ***************************** C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASRE.EQ.'PARA')THEN ISTEPN='7700' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(NUMPRD.GT.0)THEN DO7710IE=1,NUMPRD IH1=JENAM1(IE) IH2=JENAM2(IE) IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,7711)IE,JENAM1(IE),JENAM2(IE),X0(IE) 7711 FORMAT('IE,JENAM1(IE),JENAM2(IE),X0(IE) = ', 1 I8,2X,2A4,E15.7) CALL DPWRST('XXX','BUG ') ENDIF DO7720J=1,NUMNAM IF(IUSE(J).EQ.'P'.AND. 1 IHNAME(J).EQ.IH1.AND.IHNAM2(J).EQ.IH2)THEN IECOL2(IE)=J IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,7731)IE,J,IECOL2(IE),X0(IE) 7731 FORMAT('IE,J,IECOL2(IE),X0(IE) = ',3I8,E15.7) CALL DPWRST('XXX','BUG ') ENDIF VALUE(J)=X0(IE) IVALUE(J)=VALUE(J) CCCCC FOLLOWING LINE ADDED SO THAT DELETE AND RETAIN WILL NOT CCCCC DELETE PARAMETER CREATED VIA READ PARAMETER. MARCH 1994. IN(J)=1 ENDIF 7720 CONTINUE 7710 CONTINUE 7790 ENDIF GOTO7900 ELSEIF(ICASRE.EQ.'FUNC')THEN ISTEPN='7800' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(NUMFRD.GT.0)THEN CALL DPUPPE(IFUNC2,N2,IFUNC3,IBUGS2,IERROR) ISTART=IFCOL1 ISTOP=N2 DO7810IE=1,NUMFRD IH1=JENAM1(IE) IH2=JENAM2(IE) IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,7811)IE,JENAM1(IE),JENAM2(IE),IECASE(IE) 7811 FORMAT('IE,JENAM1(IE),JENAM2(IE),IECASE(IE) = ', 1 I8,2X,2A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF DO7820J=1,NUMNAM IF(IUSE(J).EQ.'F'.AND. 1 IHNAME(J).EQ.IH1.AND.IHNAM2(J).EQ.IH2)THEN IECOL2(IE)=J IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,7826)IE,J 7826 FORMAT('IE,J = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF IHLEFT=IH1 IHLEF2=IH2 NEWNAM='NO' IF(IECASE(IE).EQ.'NEW')NEWNAM='YES' ILISTL=J C IF(NUMFRD.EQ.1)THEN IF(N2.LE.0)GOTO7832 ICOL1=1 ICOL2=N2 IF(ICOL2.GT.ICOL1+N2-1)ICOL2=ICOL1+N2-1 I2=0 DO7831I=ICOL1,ICOL2 I2=I2+1 IFUNC3(I2)=IFUNC2(I2) 7831 CONTINUE 7832 CONTINUE N3=I2 C ELSE IWORD=IE IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,7841)ICOL1,ICOL2,ISTART,ISTOP,N2,N3, 1 IE,IWORD 7841 FORMAT('ICOL1,ICOL2,ISTART,ISTOP,N2,N3,IE,IWORD = ', 1 8I8) CALL DPWRST('XXX','BUG ') ENDIF CALL DPEXW2(IFUNC2,N2,ISTART,ISTOP,IWORD, 1 ICOL1,ICOL2,IFUNC3,N3, 1 IBUGS2,ISUBRO,IERROR) IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,7841)ICOL1,ICOL2,ISTART,ISTOP,N2,N3, 1 IE,IWORD CALL DPWRST('XXX','BUG ') ENDIF ENDIF C CALL DPINFU(IFUNC3,N3,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1 NUMNAM,IANSLC,IWIDTH,IHLEFT,IHLEF2,ILISTL, 1 NEWNAM,MAXN2, 1 IFUNC,NUMCHF,MAXCHF,IBUGS2,IERROR) C IF(NEWNAM.EQ.'YES'.AND.IERROR.EQ.'NO')NUMNAM=NUMNAM-1 C ENDIF 7820 CONTINUE 7810 CONTINUE ENDIF GOTO7900 C ELSEIF(ICASRE.EQ.'ROWI')THEN GOTO7900 ELSE C ISTEPN='7600' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,7601)ICASRE,NUMVRD,NUMNAM,NUME 7601 FORMAT('ICASRE,NUMVRD,NUMNAM,NUME = ',A4,3I8) CALL DPWRST('XXX','BUG ') ENDIF IF(NUMVRD.GT.0)THEN DO7610IE=1,NUMVRD N=IEN(IE) ICOLVJ=IECOL2(IE) DO7620J=1,NUMNAM IF(IUSE(J).EQ.'V'.AND.IVALUE(J).EQ.ICOLVJ)THEN IUSE(J)='V' IVALUE(J)=ICOLVJ IF(N.GT.IN(J))IN(J)=N IVSTAR(J)=MAXN*(ICOLVJ-1)+1 IVSTOP(J)=MAXN*(ICOLVJ-1)+N ENDIF 7620 CONTINUE 7610 CONTINUE ENDIF C NUMVRP=NUMVRD+1 IF(ICASRE.EQ.'MATR')GOTO7690 IF(NUMVRP.GT.NUME)GOTO7690 DO7650IE=NUMVRP,NUME IEREV=NUME-IE+NUMVRP IF(IECASE(IEREV).EQ.'NEW')THEN INAM=NUMNAM IHNAME(INAM)=' ' IHNAM2(INAM)=' ' IUSE(INAM)=' ' IVALUE(INAM)=0 IN(INAM)=0 NUMNAM=NUMNAM-1 NUMCOL=NUMCOL-1 ENDIF 7650 CONTINUE 7690 CONTINUE GOTO7900 ENDIF C 7900 CONTINUE C C ************************************* C ** STEP 12-- ** C ** WRITE OUT SUMMARY INFORMATION ** C ** ABOUT THE FILE THAT WAS READ ** C ************************************* C ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8000) 8000 FORMAT('INPUT DATA FILE SUMMARY INFORMATION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8001)IRD2 8001 FORMAT('INPUT UNIT DEVICE NUMBER = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8002)IFCOL3,IFCOL4 8002 FORMAT('INPUT FILE COLUMN LIMITS = ',I8,4X,I8) CALL DPWRST('XXX','BUG ') IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,1111)AFROW2 1111 FORMAT('AFROW2 = ',E15.7) CALL DPWRST('XXX','BUG ') ENDIF IF(IFROW2.EQ.INTINF)THEN WRITE(ICOUT,8003)IFROW1 8003 FORMAT('INPUT FILE ROW LIMITS = ',I8,4X,'INFINITY') CALL DPWRST('XXX','BUG ') ELSEIF(IFROW2.NE.INTINF)THEN WRITE(ICOUT,8004)IFROW1,IFROW2 8004 FORMAT('INPUT FILE ROW LIMITS = ',I8,4X,I8) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,8005)ISKIP 8005 FORMAT('NUMBER OF HEADER LINES SKIPPED = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8006)NUMLRD 8006 FORMAT('NUMBER OF DATA LINES READ = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMVRD.GE.1)THEN WRITE(ICOUT,8007)NUMVRD 8007 FORMAT('NUMBER OF VARIABLES READ = ',I8) CALL DPWRST('XXX','BUG ') ENDIF IF(NUMPRD.GE.1)THEN WRITE(ICOUT,8008)NUMPRD 8008 FORMAT('NUMBER OF PARAMETERS READ = ',I8) CALL DPWRST('XXX','BUG ') ENDIF IF(NUMFRD.GE.1)THEN WRITE(ICOUT,8009)NUMFRD 8009 FORMAT('NUMBER OF FUNCTIONS/STRINGS READ = ',I8) CALL DPWRST('XXX','BUG ') ENDIF IF(NCREAF.LE.0)THEN C IFRST=IFCOL3 IF(IFRST+240-1.GE.IFCOL4)THEN ILAST=IFCOL4 ELSE ILAST=IFRST+240-1 ENDIF C WRITE(ICOUT,8011) 8011 FORMAT('THE SCANNED REGION OF THE FIRST DATA LINE READ ', 1 '(TO A MAXIMUM OF 240 CHARACTERS) = ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8012)(ISTOR3(J),J=IFRST,MIN(240,ILAST)) 8012 FORMAT(240A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8013) 8013 FORMAT('THE SCANNED REGION OF THE LAST DATA LINE READ ', 1 '(TO A MAXIMUM OF 240 CHARACTERS) = ') CALL DPWRST('XXX','BUG ') IF(IENDTY.EQ.1)THEN WRITE(ICOUT,8014)(ISTOR1(J),J=IFRST,MIN(240,ILAST)) CALL DPWRST('XXX','BUG ') ELSEIF(IENDTY.EQ.2)THEN WRITE(ICOUT,8014)(ISTOR2(J),J=IFRST,MIN(240,ILAST)) 8014 FORMAT(240A1) CALL DPWRST('XXX','BUG ') ENDIF ENDIF ENDIF C C ********************************************* C ** STEP 13-- ** C ** PRINT OUT SUMMARY INFORMATION ** C ** VARIABLES/PARAMETERS/FUNCTIONS ** C ** THAT WERE READ IN. ** C ********************************************* C IF(ICASRE.EQ.'PARA')THEN IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8201) 8201 FORMAT('PARAMETER VALUE') CALL DPWRST('XXX','BUG ') C DO8210IE=1,NUME IH1=JENAM1(IE) IH2=JENAM2(IE) DO8220I=1,NUMNAM I2=I IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN WRITE(ICOUT,8226)IH1,IH2,VALUE(I2) 8226 FORMAT(A4,A4,4X,E15.7) CALL DPWRST('XXX','BUG ') ENDIF 8220 CONTINUE 8210 CONTINUE ENDIF C ELSEIF(ICASRE.EQ.'FUNC')THEN IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8301) 8301 FORMAT('FUNCTION (= STRING) CONTENT') CALL DPWRST('XXX','BUG ') C DO8310IE=1,NUME IH1=JENAM1(IE) IH2=JENAM2(IE) DO8320I=1,NUMNAM I2=I IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN JMIN=IVSTAR(I2) JMAX=IVSTOP(I2) WRITE(ICOUT,8326)IH1,IH2,(IFUNC(J),J=JMIN,JMAX) 8326 FORMAT(A4,A4,10X,80A1) CALL DPWRST('XXX','BUG ') ENDIF 8320 CONTINUE 8310 CONTINUE ENDIF C ELSEIF(ICASRE.EQ.'MATR')THEN IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8401)IHMAT1,IHMAT2,IMATNR 8401 FORMAT(' MATRIX ',A4,A4,'-- ',I8,' ROWS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8402)IMATNC 8402 FORMAT(' ',4X,4X,'-- ',I8,' COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8404) 8404 FORMAT(' VARIABLES COLUMN OBS/VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8405) 8405 FORMAT('(= COLUMN VECTORS)') CALL DPWRST('XXX','BUG ') C DO8410IE=1,NUME IH1=JENAM1(IE) IH2=JENAM2(IE) DO8420I=1,NUMNAM I2=I IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN WRITE(ICOUT,8426)IH1,IH2,IVALUE(I2),IN(I2) 8426 FORMAT(8X,A4,A4,1X,I8,5X,I8) CALL DPWRST('XXX','BUG ') ENDIF 8420 CONTINUE 8410 CONTINUE ENDIF ELSEIF(ICASRE.EQ.'ROWI')THEN CONTINUE ELSE C IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8101) 8101 FORMAT('VARIABLE COLUMN OBS/VARIABLE') CALL DPWRST('XXX','BUG ') C DO8110IE=1,NUME IH1=JENAM1(IE) IH2=JENAM2(IE) DO8120I=1,NUMNAM I2=I IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN WRITE(ICOUT,8126)IH1,IH2,IVALUE(I2),IN(I2) 8126 FORMAT(A4,A4,1X,I8,5X,I8) CALL DPWRST('XXX','BUG ') ENDIF 8120 CONTINUE 8110 CONTINUE ENDIF GOTO8800 ENDIF C C *************************************** C ** STEP 88-- ** C ** FOR THE FILE CASE, ** C ** CLOSE THE FILE. ** C *************************************** C 8800 CONTINUE ISTEPN='88' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'YES'.AND.ICURST.EQ.'OPEN')GOTO8810 GOTO8890 8810 CONTINUE IENDFI='OFF' IREWIN='ON' IF(IREARW.EQ.'ON')THEN CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IREACS='CLOSED' ENDIF 8890 CONTINUE C C ****************************************** C ** STEP 89-- ** C ** IF THE MACRO STATUS IS OPEN ** C ** THEN CHANGE IDEV FROM READ TO MACR ** C ****************************************** C 8900 CONTINUE CCCCC IF(IMACST.EQ.'OPFI')IDEV='MACR' CCCCC IF(IMACCS.EQ.'OPEN')IDEV='MACR' C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE C IF(IZCHCS.EQ.'OPEN')THEN CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IZCHCS='CLOSED' ENDIF C IFILQU=IFILQ2 C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'READ')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPREAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFROW1,AFROW2,ICASRE 9012 FORMAT('IFROW1,AFROW2,ICASRE = ',I8,2X,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFCOL1,IFCOL2 9013 FORMAT('IFCOL1,IFCOL2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISKIP,IBUGS2,IBUGQ 9014 FORMAT('ISKIP,IBUGS2,IBUGQ = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMVRD,NUMPRD,NUMFRD 9016 FORMAT('NUMVRD,NUMPRD,NUMFRD = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IMACRO,IMACNU,IMACCS 9017 FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IRD,IRD2 9018 FORMAT('IRD,IRD2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IOSW,IOFILE,IOTERM 9019 FORMAT('IOSW,IOFILE,IOTERM = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)IBUGS2,ISUBRO,IERROR 9020 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IOUNIT 9021 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IFILE 9022 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)ISTAT 9023 FORMAT('ISTAT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)IFORM 9024 FORMAT('IFORM = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)IACCES 9025 FORMAT('IACCES = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)IPROT 9026 FORMAT('IPROT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)ICURST 9027 FORMAT('ICURST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IENDFI 9028 FORMAT('IENDFI = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IREWIN 9029 FORMAT('IREWIN = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)ISUBN0 9031 FORMAT('ISUBN0 = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)IERRFI 9032 FORMAT('IERRFI = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)NUMNAM 9033 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)N2,MAXN2,N3 9041 FORMAT('N2,MAXN2,N3 = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)(IFUNC2(I),I=1,100) 9042 FORMAT('(IFUNC2(I),I=1,100) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)(IFUNC3(I),I=1,100) 9043 FORMAT('(IFUNC3(I),I=1,100) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)IHMAT1,IHMAT2,INAMMA,IMATC1,IMATNR,IMATNC 9051 FORMAT('IHMAT1,IHMAT2,INAMMA,IMATC1,IMATNR,IMATNC = ', 1 A4,2X,A4,2X,4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9061)NCREAF 9061 FORMAT('NCREAF = ',I8) CALL DPWRST('XXX','BUG ') IF(NCREAF.GE.1)THEN WRITE(ICOUT,9062)(ICREAF(I:I),I=1,NCREAF) 9062 FORMAT('(ICREAF(I:I),I=1,NCREAF) = ',80A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,9071)IREARW 9071 FORMAT('IREARW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9072)ICOMCH,ICOMSW 9072 FORMAT('ICOMCH,ICOMSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END