C COPYRIGHT (C) 1983 GLENN EVERHART C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY. SUBROUTINE USRCMD(CMDLIN,ICODE,IGOTIT) CHARACTER*80 CMDSTR BYTE CMLN(80) EQUIVALENCE(CMLN,CMDSTR) C DUMMY PLACE FOR USER COMMANDS TO PARSE CMDLIN AND HANDLE C ADDITIONAL COMMANDS FOR VMS PORTACALC. INCLUDE 'VKLUGPRM.FTN' C DEFINE VALUE AREA FOR SPREAD SHEET. MORE WILL BE NEEDED GENERALLY C OUT OF COMMONS, BUT AT A MINIMUM, THIS WILL ALLOW SOME ACCESS TO C USEFUL NUMBERS. LOOK IN XQTCMD FOR MORE... LOGICAL*1 AVBLS(20,27),WRK(128),VBLS(8,RRWP,RCLP) INTEGER*2 TYPE(RRWP,RCLP),VLEN(9) INTEGER*2 IOLVL,FOOBAR COMMON/FOOBAR/FOOBAR COMMON/IOLVL/IOLVL REAL*8 XAC,XVBLS(RRWP,RCLP) REAL*8 TAC,UAC,VAC INTEGER*4 JVBLS(2,RRWP,RCLP) EQUIVALENCE(XAC,AVBLS(1,27)) EQUIVALENCE(TAC,AVBLS(1,20)) EQUIVALENCE(UAC,AVBLS(1,21)) EQUIVALENCE(VAC,AVBLS(1,22)) EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1)) EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1)) COMMON/V/TYPE,AVBLS,VBLS,VLEN c available parsing aid: c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid) c where line(ibgn... lend) is scanned. If variable found c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for c variable found if any. lstchr is last char found+1... C OTHER USEFUL ROUTINES IN THE SHEET: C GN(LAST,LEND,NUMBER,LINE) C LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND C RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A C BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND C HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON C NUMERIC. C INDEX(LINE,CHAR) C EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER C THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE C MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR). C NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH C RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH C FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER... C PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE LOGICAL*1 CMDLIN(132) INTEGER*4 ISTTS C C INSERT CODE FOR ADDING A LIB$SPAWN CALL HERE TO PASS COMMANDS TO C DCL IF THEY BEGIN WITH A $ CHARACTER. IGOTIT=0 IF(CMDLIN(1).NE.'$'.AND.CMDLIN(1).NE.'}')GOTO 8000 C C HERE CALL THE LIB$SPAWN WITH THE COMMAND LINE AS AN ARGUMENT... DO 1000 NN=1,80 1000 CMLN(NN)=CMDLIN(NN+1) CMLN(80)=13 ! ADD C.R. AFTER LINE C ABOVE, INSERT A CR AFTER CMD LINE ISTTS=LIB$SPAWN(CMDSTR) C ASSUME WE NEED A REDRAW AFTER THE SPAWN FINISHES IF(CMDLIN(1).NE.'}')GOTO 750 WRITE(6,760) 760 FORMAT(' PRESS RETURN TO REDRAW SPREADSHEET>') READ(IOLVL,761,END=800,ERR=800)N 761 FORMAT(4A1) 750 continue 950 CONTINUE ICODE=2 C FLAG THE MAIN COMMAND PARSER WE HANDLED THE COMMAND IGOTIT=1 GOTO 9990 8000 CONTINUE IF(CMDLIN(1).NE.'D'.OR.CMDLIN(2).NE.'T'.OR.CMDLIN(3).NE.'R') 1 GOTO 8990 IGOTIT=1 ICODE=2 CALL DTRCMD(CMDLIN(4)) C ISSUE DATATRIEVE COMMAND... 8990 CONTINUE IF(CMDLIN(1).NE.'F'.OR.CMDLIN(2).NE.'I'.OR.CMDLIN(3).NE.'L') 1 GOTO 9990 IGOTIT=1 C FLAG FOR RECALCULATION BUT NOT TOTAL REDISPLAY IF PREFIX IS C 'FIL' RATHER THAN 'DTR'... ICODE=3 CALL DTRCMD(CMDLIN(4)) C ISSUE DATATRIEVE COMMAND... C 9990 CONTINUE RETURN 800 CONTINUE CLOSE(UNIT=IOLVL) C RESET TO NORMAL I/O OFF CONSOLE. FOOBAR=0 IOLVL=5 CLOSE(UNIT=5) OPEN(UNIT=5,FILE='SYS$COMMAND:',CARRIAGECONTROL='NONE') C REOPEN CONSOLE IN CASE OF INITIALIZER FILES... GOTO 750 END