Linux Cubed Series 3: Developer Tools

home *** CD-ROM | disk | FTP | other *** search

/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istpl / POLOPT.MAC.f < prev

Wrap

Text File | 1989-03-04 | 31.4 KB | 1,084 lines

C--------------------------------------------------------- C TOOLPACK/1 Release: 2.4 C--------------------------------------------------------- C--------------------------------------------------------- C TOOLPACK/1 Release: 2.4 C--------------------------------------------------------- C The following defines must have these values as OUTTOK/RDTOK expect C them to - if they must be changed, look at OUTTOK & RDTOK. SUBROUTINE POLOPT(SPEC,ISSED) INTEGER SPEC(*) LOGICAL ISSED C ------------------------------------------------------------------------ C C P O L O P T - set POLish OPTion C C ------------------------------------------------------------------------ C--------------------------------------------------------- C TOOLPACK/1 Release: 2.4 C--------------------------------------------------------- C C TKLAST = LAST TOKEN NUMBER C INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI, + TDATA ,TDO ,TDIMEN,TELSE ,TELSIF,TEND ,TENDFI,TENDIF, + TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF ,TIMPLI, + TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD , + TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO ,TWRITE, + TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA, + TEQUAL,TCOLON,TLPARN,TRPARN,TLE ,TLT ,TEQ ,TNE , + TGE ,TGT ,TAND ,TOR ,TEQV ,TNEQV ,TNOT ,TSTAR , + TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST, + TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT, + TFMTKD,TENDKD,TERRKD,TKLAST PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5, + TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO =10, + TDIMEN=11,TELSE =12,TELSIF=13,TEND =14,TENDFI=15, + TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20, + TFORMA=21,TGOTO =22,TIF =23,TIMPLI=24,TINQUI=25, + TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30, + TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35, + TSTOP =36,TSUBRO=37,TTHEN =38,TTO =39,TWRITE=40, + TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45, + TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50, + TLPARN=51,TRPARN=52,TLE =53,TLT =54,TEQ =55, + TNE =56,TGE =57,TGT =58,TAND =59,TOR =60, + TEQV =61,TNEQV =62,TNOT =63,TSTAR =64,TDSTAR=65, + TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70, + TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75, + TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80, + TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83) COMMON/MARGIN/LMARGS,RMARGS,LMARGC,RMARGC INTEGER LMARGS,RMARGS,LMARGC,RMARGC COMMON/CONTIN/CONCHR,CONCNT INTEGER CONCHR,CONCNT COMMON/LFORM/LABELF,LABELC INTEGER LABELF,LABELC COMMON/INDENT/INDDO,INDIF,INDCON,INDCMT,MAXIND INTEGER INDDO,INDIF,INDCON,MAXIND LOGICAL INDCMT COMMON/SEQNUM/SEQINI,SEQINC,SEQDIG,SEQFIL,SEQRQD INTEGER SEQINI,SEQINC,SEQDIG,SEQFIL LOGICAL SEQRQD COMMON/SPACNG/SPBEF,SPAFT INTEGER SPBEF(-2:TKLAST,0:2),SPAFT(-2:TKLAST,0:2) COMMON/INTBRK/BRPRIO INTEGER BRPRIO(-2:TKLAST,0:2) COMMON/BLINES/BLAFT,BLBEF,BLADEC,BLCHAR INTEGER BLAFT(-2:TKLAST),BLBEF(-2:TKLAST),BLCHAR LOGICAL BLADEC COMMON/RELBL/FLBINI,FLBINC,SLBINI,SLBINC,RLBFMT,RLBSTM INTEGER FLBINI,FLBINC,SLBINI,SLBINC LOGICAL RLBFMT,RLBSTM COMMON/DOCON/DOCONI,NDOCON,DOCONS,IOTHCO LOGICAL DOCONI,IOTHCO INTEGER NDOCON,DOCONS(30) COMMON/CMT/CMMODE,CBOX,CBTOP,CBSIDE,CMCHAR INTEGER CMMODE,CBOX,CBTOP,CBSIDE,CMCHAR COMMON/CASE/KWCASE,IDCASE,STRCAS,CMCASE,FFCASE INTEGER KWCASE,IDCASE,STRCAS,CMCASE,FFCASE COMMON/ASGLUP/VLEN INTEGER VLEN COMMON/MOVFMT/MOVEF,MFFLAG LOGICAL MOVEF,MFFLAG COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY COMMON/DECLUP/DLUP,DLEN,DLUPOS LOGICAL DLUP INTEGER DLEN,DLUPOS COMMON/TRCOPT/TRACE LOGICAL TRACE COMMON/OPT15C/INDDOC,DELSED,BRKLIF LOGICAL INDDOC,DELSED,BRKLIF COMMON/ERROPT/ERRCMT LOGICAL ERRCMT COMMON/CVTOPT/CVTHFM,FMSBRK LOGICAL CVTHFM,FMSBRK COMMON/REMTOK/RMOPCF LOGICAL RMOPCF INTEGER PARTBL(355),XOPTBL(20),BOXTBL(25),KWCTBL(31),CASTBL(35) INTEGER IDCTBL(56),CMMTBL(46),CONTBL(33),LBFTBL(44) INTEGER BOXTBX(3),KWCTBX(3),CASTBX(3),IDCTBX(5),CMMTBX(4), + CONTBX(3),LBFTBX(3) LOGICAL FIRST SAVE INTEGER OPTNUM,I,J,STATUS,TMP CHARACTER*132 ERRTXT INTEGER ZKWLUK,ZSPLIT,INDEXX,ZYESNO EXTERNAL ZKWLUK,ZSPLIT,INDEXX,ZITOF,REMARK,ZYESNO DATA (PARTBL(I),I=1,125)/53, + 98,108,97,100,101,99,129, + 98,108,97,102,116,129, + 98,108,98,101,102,129, + 98,108,99,104,97,114,129, + 98,114,107,108,105,102,129, + 98,114,112,114,105,111,129, + 99,98,111,120,129, + 99,98,115,105,100,101,129, + 99,98,116,111,112,129, + 99,109,99,97,115,101,129, + 99,109,99,104,97,114,129, + 99,109,109,111,100,101,129, + 99,111,110,99,104,114,129, + 99,118,116,104,102,109,129, + 100,101,108,115,101,100,129, + 100,108,101,110,129, + 100,108,117,112,129, + 100,111,99,111,110,105,129, + 101,114,114,99,109,116,129/ DATA (PARTBL(I),I=126,235)/ + 102,102,99,97,115,101,129, + 102,108,98,105,110,99,129, + 102,108,98,105,110,105,129, + 102,109,115,98,114,107,129, + 105,100,99,97,115,101,129, + 105,110,100,99,109,116,129, + 105,110,100,99,111,110,129, + 105,110,100,100,111,129, + 105,110,100,100,111,99,129, + 105,110,100,105,102,129, + 105,111,116,104,99,111,129, + 107,119,99,97,115,101,129, + 108,97,98,101,108,99,129, + 108,97,98,101,108,102,129, + 108,109,97,114,103,99,129, + 108,109,97,114,103,115,129/ DATA (PARTBL(I),I=236,355)/ + 109,111,118,101,102,129, + 114,108,98,102,109,116,129, + 114,108,98,115,116,109,129, + 114,109,97,114,103,99,129, + 114,109,97,114,103,115,129, + 114,109,111,112,99,102,129, + 115,101,113,100,105,103,129, + 115,101,113,102,105,108,129, + 115,101,113,105,110,99,129, + 115,101,113,105,110,105,129, + 115,101,113,114,113,100,129, + 115,108,98,105,110,99,129, + 115,108,98,105,110,105,129, + 115,112,97,102,116,129, + 115,112,98,101,102,129, + 115,116,114,99,97,115,129, + 116,114,97,99,101,129, + 118,108,101,110,129/ DATA XOPTBL/2, + 110,97,103,95,115,116,97,110,100,97, +114,100,129, + 113,117,101,114,121,129/ DATA BOXTBL/3, + 104,97,108,102,95,98,111,120,129, + 110,111,110,101,129, + 119,104,111,108,101,95,98,111,120,129/ DATA KWCTBL/3, + 108,111,119,101,114,99,97,115,101,129, + 109,105,120,101,100,99,97,115,101,129, + 117,112,112,101,114,99,97,115,101,129/ DATA CASTBL/3, + 108,111,119,101,114,99,97,115,101,129, + 111,114,105,103,105,110,97,108,95, +99,97,115,101,129, + 117,112,112,101,114,99,97,115,101,129/ DATA IDCTBL/5, + 105,110,118,101,114,116,99,97,115,101,129, + 108,111,119,101,114,99,97,115,101,129, + 109,105,120,101,100,99,97,115,101,129, + 111,114,105,103,105,110,97,108,95,99, +97,115,101,129, + 117,112,112,101,114,99,97,115,101,129/ DATA CMMTBL/4, + 110,111,114,109,97,108,129, + 115,107,105,112,95,108,101,97,100,105, +110,103,95,98,108,97,110,107,115,129, + 116,114,117,110,99,97,116,101,129, + 118,101,114,98,97,116,105,109,129/ DATA CONTBL/3, + 97,108,112,104,97,98,101,116,105,99,129, + 97,108,112,104,97,110,117,109,101,114,105, +99,129, + 110,117,109,101,114,105,99,129/ DATA LBFTBL/3, + 108,101,102,116,95,106,117,115,116,105, +102,105,101,100,129, + 114,105,103,104,116,95,106,117,115,116, +105,102,105,101,100,129, + 122,101,114,111,95,112,97,100,100,101, +100,129/ DATA BOXTBX/1,0,2/,KWCTBX/1,2,0/,CASTBX/2,0,1/,IDCTBX/4,2,3,0,1/ DATA CMMTBX/0,1,3,2/,CONTBX/2,3,1/,LBFTBX/0,1,2/ DATA FIRST/.TRUE./ IF (FIRST) THEN FIRST=.FALSE. QUERY=.FALSE. END IF STATUS=ZSPLIT(SPEC,LHS,RHS) LPPOS=INDEXX(LHS,40) IF (LPPOS.GT.0) LHS(LPPOS)=129 OPTNUM=ZKWLUK(LHS,PARTBL) IF (LPPOS.GT.0) LHS(LPPOS)=40 IF (OPTNUM.GT.0) THEN GOTO (1001,1002,1003,1004,1005,1006,1007,1008,1009,1010, + 1011,1012,1013,1014,1015,1016,1017,1018,1019,1020, + 1021,1022,1023,1024,1025,1026,1027,1028,1029,1030, + 1031,1032,1033,1034,1035,1036,1037,1038,1039,1040, + 1041,1042,1043,1044,1045,1046,1047,1048,1049,1050, + 1051,1052,1053) OPTNUM ELSE IF (STATUS.EQ.-1 .AND. LPPOS.EQ.0) THEN OPTNUM=ZKWLUK(LHS,XOPTBL) END IF IF (OPTNUM.GT.0) THEN GOTO (5000,5100) OPTNUM ELSE CALL ZITOF(LHS,1,132,ERRTXT,.TRUE.) CALL REMARK('Unknown Option Ignored: '//ERRTXT) END IF END IF RETURN 1001 CALL SETLOG(BLADEC) RETURN 1002 CALL SETVEC(BLAFT) RETURN 1003 CALL SETVEC(BLBEF) RETURN 1004 CALL SETCHR(BLCHAR) RETURN 1005 CALL SETLOG(BRKLIF) RETURN 1006 CALL SETVC2(BRPRIO) RETURN 1007 IF (ISSED) THEN CALL REMARK('Cannot change CBOX in a SED') ELSE CALL SETKEY(CBOX,BOXTBL,BOXTBX) END IF RETURN 1008 CALL SETCHR(CBSIDE) RETURN 1009 CALL SETCHR(CBTOP) RETURN 1010 CALL SETKEY(CMCASE,CASTBL,CASTBX) RETURN 1011 CALL SETCHR(CMCHAR) RETURN 1012 CALL SETKEY(CMMODE,CMMTBL,CMMTBX) RETURN 1013 IF (RHS(1).EQ.39) THEN TMP=CONCHR CALL SETCHR(TMP) IF (TMP.EQ.32 .OR. TMP.EQ.48) THEN CALL BADVAL ELSE CONCHR=TMP END IF ELSE CALL SETKEY(CONCHR,CONTBL,CONTBX) END IF RETURN 1014 CALL SETLOG(CVTHFM) RETURN 1015 CALL SETLOG(DELSED) RETURN 1016 CALL SETINT(DLEN,0,50) RETURN 1017 CALL SETLOG(DLUP) RETURN 1018 IF (ISSED) THEN CALL REMARK('Cannot change DOCONI in a SED') ELSE CALL SETLOG(DOCONI) END IF RETURN 1019 CALL SETLOG(ERRCMT) RETURN 1020 CALL SETKEY(FFCASE,CASTBL,CASTBX) RETURN 1021 CALL SETINT(FLBINC,-99999,99999) RETURN 1022 CALL SETINT(FLBINI,0,99999) RETURN 1023 CALL SETLOG(FMSBRK) RETURN 1024 CALL SETKEY(IDCASE,IDCTBL,IDCTBX) RETURN 1025 CALL SETLOG(INDCMT) RETURN 1026 CALL SETINT(INDCON,-60,60) RETURN 1027 CALL SETINT(INDDO,0,60) RETURN 1028 CALL SETLOG(INDDOC) RETURN 1029 CALL SETINT(INDIF,0,60) RETURN 1030 IF (ISSED) THEN CALL REMARK('Cannot change IOTHCO in a SED') ELSE CALL SETLOG(IOTHCO) END IF RETURN 1031 CALL SETKEY(KWCASE,KWCTBL,KWCTBX) RETURN 1032 CALL SETINT(LABELC,1,5) RETURN 1033 CALL SETKEY(LABELF,LBFTBL,LBFTBX) RETURN 1034 CALL SETINT(LMARGC,2,80) RETURN 1035 CALL SETINT(LMARGS,7,40) RETURN 1036 IF (ISSED) THEN CALL REMARK('Cannot change MOVEF in a SED') ELSE CALL SETLOG(MOVEF) END IF RETURN 1037 IF (ISSED) THEN CALL REMARK('Cannot change RLBFMT in a SED') ELSE CALL SETLOG(RLBFMT) END IF RETURN 1038 IF (ISSED) THEN CALL REMARK('Cannot change RLBSTM in a SED') ELSE CALL SETLOG(RLBSTM) END IF RETURN 1039 CALL SETINT(RMARGC,10,132) RETURN 1040 CALL SETINT(RMARGS,10,132) RETURN 1041 CALL SETLOG(RMOPCF) RETURN 1042 CALL SETINT(SEQDIG,1,8) RETURN 1043 CALL SETCHR(SEQFIL) RETURN 1044 CALL SETINT(SEQINC,1,999) RETURN 1045 IF (ISSED) THEN CALL REMARK('Cannot change SEQINI in a SED') ELSE CALL SETINT(SEQINI,0,9999) END IF RETURN 1046 CALL SETLOG(SEQRQD) RETURN 1047 CALL SETINT(SLBINC,1,99999) RETURN 1048 CALL SETINT(SLBINI,1,99999) RETURN 1049 CALL SETVC2(SPAFT) RETURN 1050 CALL SETVC2(SPBEF) RETURN 1051 CALL SETKEY(STRCAS,CASTBL,CASTBX) RETURN 1052 CALL SETLOG(TRACE) RETURN 1053 CALL SETINT(VLEN,0,12) RETURN C ******* C * C * eXtended OPtions C * C ******* C XOP: nag_standard 5000 IF (QUERY) THEN CALL ZMESS('"Nag_standard" requested:',1) IF (ZYESNO(-2).EQ.-3) RETURN END IF INDDO=3 INDIF=3 INDCON=-3 INDCMT=.TRUE. CMMODE=1 * SPAFT(TIF,0)=0 SPAFT(TOPEN,0)=0 SPBEF(TTHEN,0)=0 * DO 5001 I=0,2 SPBEF(TRPARN,I)=1 SPAFT(TRPARN,I)=0 SPBEF(TLPARN,I)=0 5001 SPAFT(TLPARN,I)=1 * DO 5002 I=0,2 SPBEF(TCOMMA,I)=0 5002 SPAFT(TCOMMA,I)=1 * DO 5003 I=TLE,TGT DO 5003 J=0,2 SPBEF(I,J)=1 5003 SPAFT(I,J)=1 * DO 5004 I=TAND,TNEQV DO 5004 J=0,2 SPBEF(I,J)=2 5004 SPAFT(I,J)=2 * DO 5005 I=0,2 SPBEF(TPLUS,I)=1 SPAFT(TPLUS,I)=1 SPBEF(TMINUS,I)=1 SPAFT(TMINUS,I)=1 5005 CONTINUE * DO 5006 I=0,2 SPBEF(TCOLON,I)=0 5006 SPAFT(TCOLON,I)=1 * VLEN=6 DLUP=.TRUE. BRKLIF=.TRUE. RETURN C XOP: query 5100 IF (QUERY) THEN CALL ZMESS('Ending QUERY mode..',1) QUERY=(ZYESNO(-2).EQ.-3) ELSE QUERY=.TRUE. END IF END C ---------------------------------------------------------------------- C C B A D V A L - BAD VALue for a parameter C SUBROUTINE BADVAL COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE INTEGER I CHARACTER*132 ERRTXT INTRINSIC MAX INTEGER LENGTH EXTERNAL REMARK,ZITOF,ZFTOI,SCOPY,LENGTH I=MIN(LENGTH(RHS),40) CALL ZFTOI('] for option ',1,14,RHS(I+1),.FALSE.) LHS(40)=129 CALL SCOPY(LHS,1,RHS,I+14) CALL ZITOF(RHS,1,132,ERRTXT,.TRUE.) CALL REMARK('Incorrect value ['//ERRTXT) END C ---------------------------------------------------------------------- C C N O T S U B - (remark) Not a subscripted option C SUBROUTINE NOTSUB COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE CHARACTER*132 ERRTXT EXTERNAL ZITOF,REMARK CALL ZITOF(LHS,1,LPPOS,ERRTXT,.TRUE.) CALL REMARK('Not a subscripted option: '//ERRTXT) END C ---------------------------------------------------------------------- C C M I S S U B - (remark) Missing subscript C SUBROUTINE MISSUB COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE CHARACTER*132 ERRTXT EXTERNAL ZITOF,REMARK CALL ZITOF(LHS,1,132,ERRTXT,.TRUE.) CALL REMARK('Missing subscript on option: '//ERRTXT) END C ---------------------------------------------------------------------- C C B A D S U B - (remark) Bad subscript value C SUBROUTINE BADSUB COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE CHARACTER*132 ERRTXT EXTERNAL ZITOF,REMARK CALL ZITOF(LHS,1,132,ERRTXT,.TRUE.) CALL REMARK('Incorrect value for subscript: '//ERRTXT) END C ---------------------------------------------------------------------- C C O U T O P T - Output requested option C SUBROUTINE OUTOPT COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE EXTERNAL ZCHOUT,PUTLIN,PUTC CALL ZCHOUT('Option change: ',1) CALL PUTLIN(LHS,1) CALL PUTC(61) CALL PUTLIN(RHS,1) CALL ZCHOUT(' [old value=] ',1) END C ---------------------------------------------------------------------- C C S E T L O G - SET a LOGical parameter C SUBROUTINE SETLOG(VAR) LOGICAL VAR COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY INTEGER TFTBL(16) SAVE INTEGER TEMP INTEGER ZKWLUK,ZYESNO EXTERNAL ZKWLUK,ZYESNO,ZMESS DATA TFTBL/2, + 46,102,97,108,115,101,46,129, + 46,116,114,117,101,46,129/ IF (LPPOS.GT.0) THEN CALL NOTSUB ELSE TEMP=ZKWLUK(RHS,TFTBL) IF (TEMP.LE.0) THEN CALL BADVAL ELSE IF (QUERY .AND. ((TEMP.EQ.2).NEQV.VAR)) THEN CALL OUTOPT IF (VAR) THEN CALL ZMESS('..TRUE..',1) ELSE CALL ZMESS('..FALSE..',1) END IF IF (ZYESNO(-2).EQ.-2) VAR=(TEMP.EQ.2) ELSE VAR=(TEMP.EQ.2) END IF END IF END C ---------------------------------------------------------------------- C C S E T I N T - SET INTeger parameter C SUBROUTINE SETINT(VAR,LB,UB) INTEGER VAR,LB,UB COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE INTEGER PNTR,LASTP,TEMP,PTR INTEGER ZSCTOI,ZYESNO EXTERNAL ZSCTOI,SKIPBL,ZYESNO,PUTDEC,PUTC IF (LPPOS.NE.0) THEN CALL NOTSUB ELSE PNTR=1 CALL SKIPBL(RHS,PNTR) LASTP=PNTR C If front of RHS matches whole of LHS, we have an incremental setting, C vis. LMARGS=LMARGS+3 PTR=1 100 IF (LHS(PTR).EQ.RHS(PNTR) .AND. LHS(PTR).NE.129) THEN PTR=PTR+1 PNTR=PNTR+1 GOTO 100 END IF C Make sure an incremental setting begins with + or - IF (LHS(PTR).EQ.129 .AND. (RHS(PNTR).EQ.43 .OR. + RHS(PNTR).EQ.45)) THEN C It is an incremental setting - fix check for legal number LASTP=PNTR TEMP=VAR+ZSCTOI(RHS,PNTR) ELSE C Not an incremental setting - restore PNTR value PNTR=LASTP TEMP=ZSCTOI(RHS,PNTR) END IF IF (PNTR.EQ.LASTP .OR. TEMP.LT.LB .OR. TEMP.GT.UB .OR. + RHS(PNTR).NE.129) THEN CALL BADVAL ELSE IF (QUERY .AND. TEMP.NE.VAR) THEN CALL OUTOPT CALL PUTDEC(VAR,1) CALL PUTC(10) IF (ZYESNO(-2).EQ.-2) VAR=TEMP ELSE VAR=TEMP END IF END IF END C ---------------------------------------------------------------------- C C S E T C H R - SET CHaRacter variable C SUBROUTINE SETCHR(VAR) INTEGER VAR COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE INTEGER ZYESNO EXTERNAL ZYESNO,PUTC,ZMESS IF (LPPOS.NE.0) THEN CALL NOTSUB ELSE IF (RHS(1).NE.39 .OR. RHS(3).NE.39 .OR. + RHS(4).NE.129) THEN CALL BADVAL ELSE IF (QUERY .AND. VAR.NE.RHS(2)) THEN CALL OUTOPT CALL PUTC(39) CALL PUTC(VAR) CALL ZMESS('''',1) IF (ZYESNO(-2).EQ.-2) VAR=RHS(2) ELSE VAR=RHS(2) END IF END C ---------------------------------------------------------------------- C C S E T V E C - Set vector element C SUBROUTINE SETVEC(VECTOR) C--------------------------------------------------------- C TOOLPACK/1 Release: 2.4 C--------------------------------------------------------- C C TKLAST = LAST TOKEN NUMBER C INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI, + TDATA ,TDO ,TDIMEN,TELSE ,TELSIF,TEND ,TENDFI,TENDIF, + TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF ,TIMPLI, + TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD , + TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO ,TWRITE, + TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA, + TEQUAL,TCOLON,TLPARN,TRPARN,TLE ,TLT ,TEQ ,TNE , + TGE ,TGT ,TAND ,TOR ,TEQV ,TNEQV ,TNOT ,TSTAR , + TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST, + TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT, + TFMTKD,TENDKD,TERRKD,TKLAST PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5, + TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO =10, + TDIMEN=11,TELSE =12,TELSIF=13,TEND =14,TENDFI=15, + TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20, + TFORMA=21,TGOTO =22,TIF =23,TIMPLI=24,TINQUI=25, + TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30, + TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35, + TSTOP =36,TSUBRO=37,TTHEN =38,TTO =39,TWRITE=40, + TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45, + TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50, + TLPARN=51,TRPARN=52,TLE =53,TLT =54,TEQ =55, + TNE =56,TGE =57,TGT =58,TAND =59,TOR =60, + TEQV =61,TNEQV =62,TNOT =63,TSTAR =64,TDSTAR=65, + TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70, + TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75, + TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80, + TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83) INTEGER VECTOR(-2:TKLAST) COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE INTEGER PNTR,I,TEMP,LASTP INTEGER EVTSUB INTEGER ZSCTOI,ZYESNO EXTERNAL ZSCTOI,ZYESNO,PUTDEC,PUTC IF (EVTSUB(I).EQ.-1) RETURN PNTR=1 LASTP=PNTR TEMP=ZSCTOI(RHS,PNTR) IF (PNTR.EQ.LASTP) THEN CALL BADVAL ELSE IF (QUERY .AND. VECTOR(I).NE.TEMP) THEN CALL OUTOPT CALL PUTDEC(VECTOR(I),1) CALL PUTC(10) IF (ZYESNO(-2).EQ.-2) VECTOR(I)=TEMP ELSE VECTOR(I)=TEMP END IF END C ---------------------------------------------------------------------- C C S E T V C 2 - Set element of 2-dimensional vector C SUBROUTINE SETVC2(VECTOR) C--------------------------------------------------------- C TOOLPACK/1 Release: 2.4 C--------------------------------------------------------- C C TKLAST = LAST TOKEN NUMBER C INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI, + TDATA ,TDO ,TDIMEN,TELSE ,TELSIF,TEND ,TENDFI,TENDIF, + TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF ,TIMPLI, + TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD , + TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO ,TWRITE, + TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA, + TEQUAL,TCOLON,TLPARN,TRPARN,TLE ,TLT ,TEQ ,TNE , + TGE ,TGT ,TAND ,TOR ,TEQV ,TNEQV ,TNOT ,TSTAR , + TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST, + TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT, + TFMTKD,TENDKD,TERRKD,TKLAST PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5, + TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO =10, + TDIMEN=11,TELSE =12,TELSIF=13,TEND =14,TENDFI=15, + TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20, + TFORMA=21,TGOTO =22,TIF =23,TIMPLI=24,TINQUI=25, + TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30, + TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35, + TSTOP =36,TSUBRO=37,TTHEN =38,TTO =39,TWRITE=40, + TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45, + TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50, + TLPARN=51,TRPARN=52,TLE =53,TLT =54,TEQ =55, + TNE =56,TGE =57,TGT =58,TAND =59,TOR =60, + TEQV =61,TNEQV =62,TNOT =63,TSTAR =64,TDSTAR=65, + TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70, + TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75, + TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80, + TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83) INTEGER VECTOR(-2:TKLAST,0:2) COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE INTEGER PNTR,I,TEMP(0:2),LASTP,ROW INTEGER EVTSUB INTEGER ZSCTOI,ZYESNO EXTERNAL ZSCTOI,ZYESNO,PUTDEC,PUTC IF (EVTSUB(ROW).EQ.-1) RETURN PNTR=1 LASTP=PNTR DO 100 I=0,2 TEMP(I)=ZSCTOI(RHS,PNTR) IF (PNTR.EQ.LASTP) THEN CALL BADVAL RETURN END IF IF (RHS(PNTR).NE.129) PNTR=PNTR+1 LASTP=PNTR 100 CONTINUE IF (QUERY .AND. (TEMP(0).NE.VECTOR(ROW,0) .OR. + TEMP(1).NE.VECTOR(ROW,1) .OR. TEMP(2).NE.VECTOR(ROW,2))) THEN CALL OUTOPT DO 200 I=0,2 CALL PUTDEC(VECTOR(ROW,I),1) 200 CALL PUTC(32) CALL PUTC(10) IF (ZYESNO(-2).EQ.-3) RETURN END IF DO 300 I=0,2 300 VECTOR(ROW,I)=TEMP(I) END C ---------------------------------------------------------------------- C C S E T K E Y - Set (integer) according to keyword value C SUBROUTINE SETKEY(VAR,TABLE,TBX) INTEGER VAR,TABLE(*),TBX(*) COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE INTEGER I,J,K,L INTEGER ZKWLUK,ZYESNO EXTERNAL ZKWLUK,ZYESNO,ZPTMES IF (LPPOS.NE.0) THEN CALL NOTSUB ELSE I=ZKWLUK(RHS,TABLE) IF (I.LE.0) THEN CALL BADVAL ELSE IF (QUERY .AND. VAR.NE.TBX(I)) THEN CALL OUTOPT J=1 100 IF (TBX(J).NE.VAR) THEN J=J+1 GOTO 100 END IF L=1 DO 300 K=2,J 200 IF (TABLE(L).NE.129) THEN L=L+1 GOTO 200 END IF L=L+1 300 CONTINUE CALL ZPTMES(TABLE(L),1) IF (ZYESNO(-2).EQ.-2) VAR=TBX(I) ELSE VAR=TBX(I) END IF END IF END C ---------------------------------------------------------------------- C C E V T S U B - Evaluate Token-name Subscript C INTEGER FUNCTION EVTSUB(RESULT) INTEGER RESULT C--------------------------------------------------------- C TOOLPACK/1 Release: 2.4 C--------------------------------------------------------- C C TKLAST = LAST TOKEN NUMBER C INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI, + TDATA ,TDO ,TDIMEN,TELSE ,TELSIF,TEND ,TENDFI,TENDIF, + TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF ,TIMPLI, + TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD , + TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO ,TWRITE, + TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA, + TEQUAL,TCOLON,TLPARN,TRPARN,TLE ,TLT ,TEQ ,TNE , + TGE ,TGT ,TAND ,TOR ,TEQV ,TNEQV ,TNOT ,TSTAR , + TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST, + TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT, + TFMTKD,TENDKD,TERRKD,TKLAST PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5, + TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO =10, + TDIMEN=11,TELSE =12,TELSIF=13,TEND =14,TENDFI=15, + TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20, + TFORMA=21,TGOTO =22,TIF =23,TIMPLI=24,TINQUI=25, + TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30, + TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35, + TSTOP =36,TSUBRO=37,TTHEN =38,TTO =39,TWRITE=40, + TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45, + TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50, + TLPARN=51,TRPARN=52,TLE =53,TLT =54,TEQ =55, + TNE =56,TGE =57,TGT =58,TAND =59,TOR =60, + TEQV =61,TNEQV =62,TNOT =63,TSTAR =64,TDSTAR=65, + TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70, + TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75, + TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80, + TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83) COMMON/TNAMES/TOKNAM CHARACTER*6 TOKNAM(-2:TKLAST) COMMON/OPTLCL/LHS,RHS,LPPOS,QUERY INTEGER LHS(134),RHS(134),LPPOS LOGICAL QUERY SAVE CHARACTER*6 SUBNAM INTEGER I INTEGER LENGTH EXTERNAL LENGTH,ZTOCAP,ZITOF IF (LPPOS.EQ.0 .OR. LHS(LENGTH(LHS)).NE.41) THEN CALL MISSUB EVTSUB=-1 ELSE SUBNAM=' ' CALL ZTOCAP(LHS(LPPOS+1)) I=LENGTH(LHS(LPPOS+1)) CALL ZITOF(LHS,LPPOS+1,LPPOS+I-1,SUBNAM,.FALSE.) I=-2 200 IF (I.LT.TKLAST .AND. TOKNAM(I).NE.SUBNAM) THEN I=I+1 GOTO 200 END IF IF (TOKNAM(I).NE.SUBNAM) THEN CALL BADSUB EVTSUB=-1 ELSE EVTSUB=-2 RESULT=I END IF END IF END