C DATATRIEVE INTERFACE FUNCTIONS c optional for VAX VMS AnalytiCalc C Include by linking with DTRIF.FOR C Exclude by linking with DTRIF.FTN C c c Attempt to provide a reasonable interface to DTR by c allowing passing of commands to DTR both interactively and c from within a cell, and retrieving numbers and text into c cells. Also permit sending replies to DTR (for replies in c procedures) from text in cells or numbers (values) in cells c so that interaction is two-way. c C GLENN EVERHART 1985 SUBROUTINE DTRINI C INITIALIZE DATATRIEVE C CALLED AT START OF PROGRAM, ONCE-FOR-ALL. C *** c c FORTRAN DATATRIEVE Access Block c LOGICAL*1 DAB$B_BID, DAB$B_BLN, DAB$B_VER_LETTER, DAB(100) INTEGER*2 DAB$W_MSG_BUF_LEN, DAB$W_MSG_LEN, 1 DAB$W_AUX_BUF_LEN, DAB$W_AUX_LEN, 2 DAB$W_IDI, DAB$W_STATE, DAB$W_REC_LENGTH, 3 DAB$W_VERSION, DAB$W_LEVEL, DAB$W_BASE_LEVEL, 4 DAB$W_UDK_INDEX, DAB$W_COLUMNS_PAGE, 5 DAB$W_TT_CHANNEL LOGICAL*4 DAB$A_MSG_BUF, DAB$A_AUX_BUF, 1 DAB$L_CONDITION, DAB$L_FLAGS, DAB$L_OPTIONS COMMON /DAB_COMMON/ 1 DAB$B_BID, 2 DAB$B_BLN, 3 DAB$L_CONDITION, 4 DAB$A_MSG_BUF, 5 DAB$W_MSG_BUF_LEN, 6 DAB$W_MSG_LEN, 7 DAB$A_AUX_BUF, 8 DAB$W_AUX_BUF_LEN, 9 DAB$W_AUX_LEN, 1 DAB$W_IDI, 2 DAB$W_STATE, 3 DAB$L_FLAGS, 4 DAB$L_OPTIONS, 5 DAB$W_REC_LENGTH, 6 DAB$W_VERSION, 7 DAB$W_LEVEL, 8 DAB$B_VER_LETTER, 9 DAB$W_BASE_LEVEL, 1 DAB$W_UDK_INDEX, 2 DAB$W_COLUMNS_PAGE, 3 DAB$W_TT_CHANNEL EQUIVALENCE (DAB, DAB$B_BID) INTEGER DTR$K_STL_CMD, DTR$K_STL_PRMPT, DTR$K_STL_LINE, 1 DTR$K_STL_MSG, DTR$K_STL_PGET, DTR$K_STL_PPUT, 2 DTR$K_STL_CONT, DTR$K_STL_UDK, DTR$K_STL_END_UDK PARAMETER (DTR$K_STL_CMD=1, 1 DTR$K_STL_PRMPT=2, 2 DTR$K_STL_LINE=3, 3 DTR$K_STL_MSG=4, 4 DTR$K_STL_PGET=5, 5 DTR$K_STL_PPUT=6, 6 DTR$K_STL_CONT=7, 7 DTR$K_STL_UDK=8, 8 DTR$K_STL_END_UDK=9) INTEGER DTR$K_SEMI_COLON_OPT, DTR$K_UNQUOTED_LIT, 1 DTR$K_SYNTAX_PROMPT, DTR$K_IMMED_RETURN, 2 DTR$K_FORMS_ENABLE, DTR$K_VERIFY, DTR$K_CONTEXT_SEARCH, 3 DTR$K_HYPHEN_DISABLED, DTR$K_MORE_COMMANDS, DTR$K_ABORT, 4 DTR$K_LOCK_WAIT PARAMETER (DTR$K_SEMI_COLON_OPT=1, 1 DTR$K_UNQUOTED_LIT=16, 2 DTR$K_SYNTAX_PROMPT=32, 3 DTR$K_IMMED_RETURN=64, 4 DTR$K_FORMS_ENABLE=128, 5 DTR$K_VERIFY=256, 6 DTR$K_CONTEXT_SEARCH=2048, 7 DTR$K_HYPHEN_DISABLED=4096, 8 DTR$K_MORE_COMMANDS=8192, 9 DTR$K_ABORT=16384, 1 DTR$K_LOCK_WAIT=32768) INTEGER DTR$M_OPT_CMD, DTR$M_OPT_PRMPT, DTR$M_OPT_LINE, 1 DTR$M_OPT_MSG, DTR$M_OPT_PGET, DTR$M_OPT_PPUT, 2 DTR$M_OPT_CONT, DTR$M_OPT_UDK, DTR$M_OPT_DTR_UDK, 3 DTR$M_OPT_END_UDK, DTR$M_OPT_UNWIND, 4 DTR$M_OPT_CONTROL_C, DTR$M_OPT_STARTUP, 5 DTR$M_OPT_FOREIGN, DTR$M_OPT_BANNER, DTR$M_OPT_REMOVE_CTLC PARAMETER (DTR$M_OPT_CMD=1, 1 DTR$M_OPT_PRMPT=2, 2 DTR$M_OPT_LINE=4, 3 DTR$M_OPT_MSG=8, 4 DTR$M_OPT_PGET=16, 5 DTR$M_OPT_PPUT=32, 6 DTR$M_OPT_CONT=64, 7 DTR$M_OPT_UDK=128, 8 DTR$M_OPT_DTR_UDK=256, 9 DTR$M_OPT_END_UDK=512, 1 DTR$M_OPT_UNWIND=1024, 2 DTR$M_OPT_CONTROL_C=2048, 3 DTR$M_OPT_STARTUP=4096, 4 DTR$M_OPT_FOREIGN=8192, 5 DTR$M_OPT_BANNER=16384, 6 DTR$M_OPT_REMOVE_CTLC=32768) INTEGER DTR$K_UDK_SET, DTR$K_UDK_SET_NO, DTR$K_UDK_SHOW, 1 DTR$K_UDK_STATEMENT, DTR$K_UDK_COMMAND PARAMETER (DTR$K_UDK_SET=1, 1 DTR$K_UDK_SET_NO=2, 2 DTR$K_UDK_SHOW=3, 3 DTR$K_UDK_STATEMENT=4, 4 DTR$K_UDK_COMMAND=5) INTEGER DTR$K_TOK_TOKEN, DTR$K_TOK_PICTURE, 1 DTR$K_TOK_FILENAME, DTR$K_TOK_COMMAND, 2 DTR$K_TOK_TEST_TOKEN PARAMETER (DTR$K_TOK_TOKEN=1, 1 DTR$K_TOK_PICTURE=2, 2 DTR$K_TOK_FILENAME=3, 3 DTR$K_TOK_COMMAND=4, 4 DTR$K_TOK_TEST_TOKEN=5) INTEGER*4 DTR$INIT INTEGER RET_STATUS CHARACTER*232 MSG_BUFF CHARACTER*232 AUX_BUFF COMMON /DTR$BUFFERS/MSG_BUFF,AUX_BUFF EXTERNAL DTR$_SUCCESS,SS$_NORMAL C *** C ********>>>>>>>><<<<<<<<******** RET_STATUS=DTR$INIT(DAB,100,MSG_BUFF,AUX_BUFF, 1 DTR$K_SEMI_COLON_OPT+DTR$K_FORMS_ENABLE+ 2 DTR$K_UNQUOTED_LIT) C DTR NOW STALLS AT COMMAND INPUT AWAITING INPUT. C LET *U FUNCTIONS HANDLE FROM THERE. IF(RET_STATUS.NE.%LOC(SS$_NORMAL))THEN CALL UVT100(1,1,1) WRITE(6,1000)RET_STATUS 1000 FORMAT(' *** DATATRIEVE INITIALIZATION FAILED. ***',I6) END IF RETURN END SUBROUTINE DTRFIN C INITIALIZE DATATRIEVE C CALLED AT END OF PROGRAM, ONCE-FOR-ALL. C *** c c FORTRAN DATATRIEVE Access Block c LOGICAL*1 DAB$B_BID, DAB$B_BLN, DAB$B_VER_LETTER, DAB(100) INTEGER*2 DAB$W_MSG_BUF_LEN, DAB$W_MSG_LEN, 1 DAB$W_AUX_BUF_LEN, DAB$W_AUX_LEN, 2 DAB$W_IDI, DAB$W_STATE, DAB$W_REC_LENGTH, 3 DAB$W_VERSION, DAB$W_LEVEL, DAB$W_BASE_LEVEL, 4 DAB$W_UDK_INDEX, DAB$W_COLUMNS_PAGE, 5 DAB$W_TT_CHANNEL LOGICAL*4 DAB$A_MSG_BUF, DAB$A_AUX_BUF, 1 DAB$L_CONDITION, DAB$L_FLAGS, DAB$L_OPTIONS COMMON /DAB_COMMON/ 1 DAB$B_BID, 2 DAB$B_BLN, 3 DAB$L_CONDITION, 4 DAB$A_MSG_BUF, 5 DAB$W_MSG_BUF_LEN, 6 DAB$W_MSG_LEN, 7 DAB$A_AUX_BUF, 8 DAB$W_AUX_BUF_LEN, 9 DAB$W_AUX_LEN, 1 DAB$W_IDI, 2 DAB$W_STATE, 3 DAB$L_FLAGS, 4 DAB$L_OPTIONS, 5 DAB$W_REC_LENGTH, 6 DAB$W_VERSION, 7 DAB$W_LEVEL, 8 DAB$B_VER_LETTER, 9 DAB$W_BASE_LEVEL, 1 DAB$W_UDK_INDEX, 2 DAB$W_COLUMNS_PAGE, 3 DAB$W_TT_CHANNEL EQUIVALENCE (DAB, DAB$B_BID) INTEGER DTR$K_STL_CMD, DTR$K_STL_PRMPT, DTR$K_STL_LINE, 1 DTR$K_STL_MSG, DTR$K_STL_PGET, DTR$K_STL_PPUT, 2 DTR$K_STL_CONT, DTR$K_STL_UDK, DTR$K_STL_END_UDK PARAMETER (DTR$K_STL_CMD=1, 1 DTR$K_STL_PRMPT=2, 2 DTR$K_STL_LINE=3, 3 DTR$K_STL_MSG=4, 4 DTR$K_STL_PGET=5, 5 DTR$K_STL_PPUT=6, 6 DTR$K_STL_CONT=7, 7 DTR$K_STL_UDK=8, 8 DTR$K_STL_END_UDK=9) INTEGER DTR$K_SEMI_COLON_OPT, DTR$K_UNQUOTED_LIT, 1 DTR$K_SYNTAX_PROMPT, DTR$K_IMMED_RETURN, 2 DTR$K_FORMS_ENABLE, DTR$K_VERIFY, DTR$K_CONTEXT_SEARCH, 3 DTR$K_HYPHEN_DISABLED, DTR$K_MORE_COMMANDS, DTR$K_ABORT, 4 DTR$K_LOCK_WAIT PARAMETER (DTR$K_SEMI_COLON_OPT=1, 1 DTR$K_UNQUOTED_LIT=16, 2 DTR$K_SYNTAX_PROMPT=32, 3 DTR$K_IMMED_RETURN=64, 4 DTR$K_FORMS_ENABLE=128, 5 DTR$K_VERIFY=256, 6 DTR$K_CONTEXT_SEARCH=2048, 7 DTR$K_HYPHEN_DISABLED=4096, 8 DTR$K_MORE_COMMANDS=8192, 9 DTR$K_ABORT=16384, 1 DTR$K_LOCK_WAIT=32768) INTEGER DTR$M_OPT_CMD, DTR$M_OPT_PRMPT, DTR$M_OPT_LINE, 1 DTR$M_OPT_MSG, DTR$M_OPT_PGET, DTR$M_OPT_PPUT, 2 DTR$M_OPT_CONT, DTR$M_OPT_UDK, DTR$M_OPT_DTR_UDK, 3 DTR$M_OPT_END_UDK, DTR$M_OPT_UNWIND, 4 DTR$M_OPT_CONTROL_C, DTR$M_OPT_STARTUP, 5 DTR$M_OPT_FOREIGN, DTR$M_OPT_BANNER, DTR$M_OPT_REMOVE_CTLC PARAMETER (DTR$M_OPT_CMD=1, 1 DTR$M_OPT_PRMPT=2, 2 DTR$M_OPT_LINE=4, 3 DTR$M_OPT_MSG=8, 4 DTR$M_OPT_PGET=16, 5 DTR$M_OPT_PPUT=32, 6 DTR$M_OPT_CONT=64, 7 DTR$M_OPT_UDK=128, 8 DTR$M_OPT_DTR_UDK=256, 9 DTR$M_OPT_END_UDK=512, 1 DTR$M_OPT_UNWIND=1024, 2 DTR$M_OPT_CONTROL_C=2048, 3 DTR$M_OPT_STARTUP=4096, 4 DTR$M_OPT_FOREIGN=8192, 5 DTR$M_OPT_BANNER=16384, 6 DTR$M_OPT_REMOVE_CTLC=32768) INTEGER DTR$K_UDK_SET, DTR$K_UDK_SET_NO, DTR$K_UDK_SHOW, 1 DTR$K_UDK_STATEMENT, DTR$K_UDK_COMMAND PARAMETER (DTR$K_UDK_SET=1, 1 DTR$K_UDK_SET_NO=2, 2 DTR$K_UDK_SHOW=3, 3 DTR$K_UDK_STATEMENT=4, 4 DTR$K_UDK_COMMAND=5) INTEGER DTR$K_TOK_TOKEN, DTR$K_TOK_PICTURE, 1 DTR$K_TOK_FILENAME, DTR$K_TOK_COMMAND, 2 DTR$K_TOK_TEST_TOKEN PARAMETER (DTR$K_TOK_TOKEN=1, 1 DTR$K_TOK_PICTURE=2, 2 DTR$K_TOK_FILENAME=3, 3 DTR$K_TOK_COMMAND=4, 4 DTR$K_TOK_TEST_TOKEN=5) CHARACTER*232 MSG_BUFF CHARACTER*232 AUX_BUFF COMMON /DTR$BUFFERS/MSG_BUFF,AUX_BUFF EXTERNAL DTR$_SUCCESS C *** C ********>>>>>>>><<<<<<<<******** CALL DTR$FINISH(DAB) C CALLED JUST BEFORE EXIT. IF IT FAILS, TOO BAD... C however, gives DTR a chance to clean up prior to image exit. RETURN END SUBROUTINE DTRCMD(LINE) LOGICAL*1 LINE(80) CHARACTER*62 LINEC C EQUIVALENCE(LINEC,LINE(1)) INCLUDE 'VKLUGPRM.FTN' 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. INTEGER RETCD LOGICAL*1 AVBLS(20,27),WRK(128),VBLS(8,RRWP,RCLP) INTEGER*2 TYPE(RRWP,RCLP),VLEN(9) REAL*8 XAC,XVBLS(RRWP,RCLP) REAL*8 TAC,UAC,VAC,WAC,YAC REAL*8 TMP INTEGER*4 JVBLS(2,RRWP,RCLP) EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25)) 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 INTEGER*2 XTNCNT,XTCFG,IPSET LOGICAL*1 XTNCMD(80) INTEGER*2 FORMFG,RCFGX,PZAP,RCONE INTEGER*2 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6 COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6 INTEGER*2 RRWACT,RCLACT COMMON/RCLACT/RRWACT,RCLACT COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS. C (IMPLEMENT FOR VAX ONLY) INTEGER KALKIT COMMON/VARYIT/KALKIT C ARGUMENTS COME IN IN ARGUMENTS IN LINE C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED... INTEGER*2 PROW,PCOL,DROW,DCOL,DRWV,DCLV COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV DIMENSION NRDSP(DRW,DCL),NCDSP(DRW,DCL) COMMON/D2R/NRDSP,NCDSP C ADD DATATRIEVE DATA STMTS HERE C *** c c FORTRAN DATATRIEVE Access Block c LOGICAL*1 DAB$B_BID, DAB$B_BLN, DAB$B_VER_LETTER, DAB(100) INTEGER*2 DAB$W_MSG_BUF_LEN, DAB$W_MSG_LEN, 1 DAB$W_AUX_BUF_LEN, DAB$W_AUX_LEN, 2 DAB$W_IDI, DAB$W_STATE, DAB$W_REC_LENGTH, 3 DAB$W_VERSION, DAB$W_LEVEL, DAB$W_BASE_LEVEL, 4 DAB$W_UDK_INDEX, DAB$W_COLUMNS_PAGE, 5 DAB$W_TT_CHANNEL LOGICAL*4 DAB$A_MSG_BUF, DAB$A_AUX_BUF, 1 DAB$L_CONDITION, DAB$L_FLAGS, DAB$L_OPTIONS COMMON /DAB_COMMON/ 1 DAB$B_BID, 2 DAB$B_BLN, 3 DAB$L_CONDITION, 4 DAB$A_MSG_BUF, 5 DAB$W_MSG_BUF_LEN, 6 DAB$W_MSG_LEN, 7 DAB$A_AUX_BUF, 8 DAB$W_AUX_BUF_LEN, 9 DAB$W_AUX_LEN, 1 DAB$W_IDI, 2 DAB$W_STATE, 3 DAB$L_FLAGS, 4 DAB$L_OPTIONS, 5 DAB$W_REC_LENGTH, 6 DAB$W_VERSION, 7 DAB$W_LEVEL, 8 DAB$B_VER_LETTER, 9 DAB$W_BASE_LEVEL, 1 DAB$W_UDK_INDEX, 2 DAB$W_COLUMNS_PAGE, 3 DAB$W_TT_CHANNEL EQUIVALENCE (DAB, DAB$B_BID) C DAB$W_STATE VALUES: C 1 CMD STALL C 2 VALUE-IN-RESPONSE-TO-PROMPT STALL C 3 PRINTLINE AVAIL STALL (HAS PRINTLINE) C 4 MESSAGE STALL (HAS MSG) C 5 PORT REC AVAIL FOR PGM TO RECEIVE C 6 DTR WAITING FOR PGM TO SEND A RECORD TO PORT C 7 NOT APPLICABLE HERE ... DTR ASYNCH READY C 8 NOT APPL. DTR USER DEFINED KEYWORD C 9 NOT APPL. DTR END USER DEF KEYWORD INTEGER DTR$K_STL_CMD, DTR$K_STL_PRMPT, DTR$K_STL_LINE, 1 DTR$K_STL_MSG, DTR$K_STL_PGET, DTR$K_STL_PPUT, 2 DTR$K_STL_CONT, DTR$K_STL_UDK, DTR$K_STL_END_UDK PARAMETER (DTR$K_STL_CMD=1, 1 DTR$K_STL_PRMPT=2, 2 DTR$K_STL_LINE=3, 3 DTR$K_STL_MSG=4, 4 DTR$K_STL_PGET=5, 5 DTR$K_STL_PPUT=6, 6 DTR$K_STL_CONT=7, 7 DTR$K_STL_UDK=8, 8 DTR$K_STL_END_UDK=9) INTEGER DTR$K_SEMI_COLON_OPT, DTR$K_UNQUOTED_LIT, 1 DTR$K_SYNTAX_PROMPT, DTR$K_IMMED_RETURN, 2 DTR$K_FORMS_ENABLE, DTR$K_VERIFY, DTR$K_CONTEXT_SEARCH, 3 DTR$K_HYPHEN_DISABLED, DTR$K_MORE_COMMANDS, DTR$K_ABORT, 4 DTR$K_LOCK_WAIT PARAMETER (DTR$K_SEMI_COLON_OPT=1, 1 DTR$K_UNQUOTED_LIT=16, 2 DTR$K_SYNTAX_PROMPT=32, 3 DTR$K_IMMED_RETURN=64, 4 DTR$K_FORMS_ENABLE=128, 5 DTR$K_VERIFY=256, 6 DTR$K_CONTEXT_SEARCH=2048, 7 DTR$K_HYPHEN_DISABLED=4096, 8 DTR$K_MORE_COMMANDS=8192, 9 DTR$K_ABORT=16384, 1 DTR$K_LOCK_WAIT=32768) INTEGER DTR$M_OPT_CMD, DTR$M_OPT_PRMPT, DTR$M_OPT_LINE, 1 DTR$M_OPT_MSG, DTR$M_OPT_PGET, DTR$M_OPT_PPUT, 2 DTR$M_OPT_CONT, DTR$M_OPT_UDK, DTR$M_OPT_DTR_UDK, 3 DTR$M_OPT_END_UDK, DTR$M_OPT_UNWIND, 4 DTR$M_OPT_CONTROL_C, DTR$M_OPT_STARTUP, 5 DTR$M_OPT_FOREIGN, DTR$M_OPT_BANNER, DTR$M_OPT_REMOVE_CTLC PARAMETER (DTR$M_OPT_CMD=1, 1 DTR$M_OPT_PRMPT=2, 2 DTR$M_OPT_LINE=4, 3 DTR$M_OPT_MSG=8, 4 DTR$M_OPT_PGET=16, 5 DTR$M_OPT_PPUT=32, 6 DTR$M_OPT_CONT=64, 7 DTR$M_OPT_UDK=128, 8 DTR$M_OPT_DTR_UDK=256, 9 DTR$M_OPT_END_UDK=512, 1 DTR$M_OPT_UNWIND=1024, 2 DTR$M_OPT_CONTROL_C=2048, 3 DTR$M_OPT_STARTUP=4096, 4 DTR$M_OPT_FOREIGN=8192, 5 DTR$M_OPT_BANNER=16384, 6 DTR$M_OPT_REMOVE_CTLC=32768) INTEGER DTR$K_UDK_SET, DTR$K_UDK_SET_NO, DTR$K_UDK_SHOW, 1 DTR$K_UDK_STATEMENT, DTR$K_UDK_COMMAND PARAMETER (DTR$K_UDK_SET=1, 1 DTR$K_UDK_SET_NO=2, 2 DTR$K_UDK_SHOW=3, 3 DTR$K_UDK_STATEMENT=4, 4 DTR$K_UDK_COMMAND=5) INTEGER DTR$K_TOK_TOKEN, DTR$K_TOK_PICTURE, 1 DTR$K_TOK_FILENAME, DTR$K_TOK_COMMAND, 2 DTR$K_TOK_TEST_TOKEN PARAMETER (DTR$K_TOK_TOKEN=1, 1 DTR$K_TOK_PICTURE=2, 2 DTR$K_TOK_FILENAME=3, 3 DTR$K_TOK_COMMAND=4, 4 DTR$K_TOK_TEST_TOKEN=5) INTEGER*2 DTRENA COMMON/DTRCMN/DTRENA LOGICAL *1 LINECL(82) C CHARACTER*70 LINEC EQUIVALENCE(LINEC,LINECL(1)) CHARACTER*80 SCRBUF LOGICAL*1 LBUF(128) CHARACTER*9 FMTB EQUIVALENCE (FMTB,LBUF(120)) CHARACTER*11 FMTBF LOGICAL*1 IFVLD LOGICAL*1 MSGBUF(110) EQUIVALENCE(MSGBUF(1),MSG_BUFF) CHARACTER*232 MSG_BUFF CHARACTER*232 AUX_BUFF COMMON /DTR$BUFFERS/MSG_BUFF,AUX_BUFF EXTERNAL DTR$_SUCCESS C *** C ********>>>>>>>><<<<<<<<******** C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE DO 3332 N=1,80 NN=81-N IF(LINE(NN).GT.32)GOTO 3333 LINE(NN)=0 3332 CONTINUE 3333 CONTINUE C SPACE FILL ENTIRE ARRAY DO 3334 N=1,82 3334 LINECL(N)=32 C CALL DTR$COMMAND TO DO COMMAND FROM COMMAND LEVEL. RETCD=1 C HANDLE DTRCMD FUNCTIONS. LINE ARRAY PASSED IN HERE C STARTS AFTER THE "DTR" SO WE CAN DECODE IT. C EXECUTE DTR COMMAND C DTRCMD (COMMAND) GIVES DTR COMMAND FACILITY AT COMMAND C LEVEL. C ALLOW DTRIMM COMMAND TO USE DTR IMMEDIATE TERMINAL C INTERFACE. THE REST CAN USE SAME COMMAND NAMES AS AFTER C THE "DB" IN *U DBXXXX COMMANDS. call scmp(LINE,%REF('IMM'),3,ICODE) IF(ICODE.NE.1)GOTO 1000 c move line down to pass the "imm" stuff and one space do 1005 n=1,56 NN=N IF(LINE(N+4).LT.32)GOTO 1006 C NNN=N 1005 linec(N:N)=char(line(n+4)) 1006 CONTINUE LINEC(NN:NN)=CHAR(32) CALL DTR$COMMAND(DAB,LINEC(1:NN)) c just allow normal DTR handling of the rest... CALL DTR$DTR(DAB,DTR$M_OPT_CMD) RETURN 1000 continue call scmp(LINE,%REF('INT'),3,ICODE) IF(ICODE.NE.1)GOTO 1400 C DTRINT - DO INTERACTIVE DTR STUFF. c move line down to pass the "int" stuff and one space do 1405 n=1,60 NN=N IF(LINE(N+4).LT.32)GOTO 1406 C NNN=N 1405 linec(N:N)=char(line(n+4)) 1406 CONTINUE LINEC(NN:NN)=CHAR(32) IF(DAB$W_STATE.EQ.DTR$K_STL_CMD)THEN CALL DTR$COMMAND(DAB,%DESCR(LINEC(1:NN))) END IF c just allow normal DTR handling of the rest... CALL DTR$CONTINUE(DAB) CALL DTR$DTR(DAB,DTR$M_OPT_UNWIND) RETURN 1400 CONTINUE CALL SCMP(LINE,%REF('CMD'),3,ICODE) IF(ICODE.NE.1)GOTO 100 C *U DBCMD COMMAND C EXECUTE DTR COMMAND C CONSTRUCT A DESCRIPTOR... DO 8 N=1,70 8 LINECL(N)=0 DO 10 N=1,60 NN=N M=LINE(4+N) C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 11 C NNN=N LINEC(N:N)= CHAR(M) 10 CONTINUE 11 CONTINUE LINEC(NN:NN)=CHAR(32) CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 20 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 20 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 20 CONTINUE CALL DTR$CONTINUE(DAB) C FLUSH ALL MESSAGES...IF MORE THAN ONE IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 20 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 20 C JUST CONTINUE IF WE ONLY GOT A MESSAGE OR PRINT LINE HERE. c no provision for printing it and we normally want to avoid c prints of this anyway. GOTO 9999 100 CONTINUE CALL SCMP(LINE,%REF('VAL'),3,ICODE) IF(ICODE.NE.1)GOTO 200 LSKIP=(LINE(4))-57 IF(LSKIP.LT.1.OR.LSKIP.GT.9)LSKIP=0 IVV=4 IF(LINE(5).EQ.ICHAR('.'))THEN IVV=IVV+1 END IF DO 110 N=1,60 NN=N M=LINE(IVV+N) C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 111 C NNN=N LINEC(N:N)=CHAR(M) 110 CONTINUE 111 CONTINUE LINEC(NN:NN)=CHAR(32) CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 120 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 130 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 120 CONTINUE CALL DTR$CONTINUE(DAB) IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 120 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 130 GOTO 9999 130 CONTINUE IF(LSKIP.GT.0)THEN DO 3346 N=1,LSKIP 3346 CALL DTR$CONTINUE(DAB) C SKIP EXTRA PRINT LINES IF NEEDED TO DO SO END IF IF(IVV.GE.5)THEN IQ=0 DO 135 N=1,110 135 IF(MSGBUF(N).EQ.ICHAR('.'))IQ=1 IVVV=0 DO 138 N=1,80 IF(MSGBUF(NN).EQ.ICHAR(':'))IVVV=N+1 NN=81-N IF(MSGBUF(NN).GT.32)GOTO 139 138 CONTINUE 139 IF(IQ.EQ.0)MSGBUF(NN+1)=46 C 46 IS ASCII PERIOD C IF WE HAVE . AS FIRST CHAR OF COMMAND THEN C ADD DECIMAL TO END OF TEXT AND START TEXT AFTER THE : OF A C POSSIBLE LIST COMMAND. ONLY ADD THE DECIMAL IF NONE IS IN C THE STRING ALREADY AND ONLY SKIP COLON IF ONE EXISTS. IF(IVVV.GT.0)THEN K=1 DO 137 N=IVVV,NN+1 MSGBUF(K)=MSGBUF(N) K=K+1 137 CONTINUE DO 136 N=K,110 136 MSGBUF(K)=32 END IF END IF C GET VALUE BACK C FORTRAN-77 HACK. USE INTERNAL READ C GETS RESULT INTO % ACCUMULATOR. READ(MSG_BUFF,140,ERR=9990)XAC c use wide format to allow correct readin of many formats 140 FORMAT(D30.15) GOTO 120 C JUST CONTINUE IF WE ONLY GOT A MESSAGE OR PRINT LINE HERE. 200 CONTINUE CALL SCMP(LINE,%REF('TXT'),3,ICODE) IF(ICODE.NE.1)GOTO 300 c get cell name now and skip the comma after it... C *U DBTXT CELL,COMMAND C GETS REPLY INTO CELL. IF NO REPLY, CELL UNCHANGED. LO=4 LHI=20 LSTCHR=20 CALL VARSCN(LINE,LO,LHI,LSTCHR,ID1,ID2,IVLD) IF(IVLD.EQ.0)GOTO 9990 C JUST SKIP COMMA, SO IT REALLY CAN BE ANY DELIMITER C IF NO DELIMITER OTHER THAN SPACE WAS GIVEN, SKIP SENDING C THE COMMAND. IF(LINE(LSTCHR).LE.32)GOTO 230 DO 210 N=1,60 NN=N M=LINE(LSTCHR+N) C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 211 C NNN=N LINEC(N:N)=CHAR(M) 210 CONTINUE 211 CONTINUE LINEC(NN:NN)=CHAR(32) XAC=0. CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 220 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 230 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 220 CONTINUE CALL DTR$CONTINUE(DAB) IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 220 GOTO 9999 230 CONTINUE C IF(LINE(LSTCHR).EQ.ICHAR(';'))CALL DTR$CONTINUE(DAB) C IF WE SEE ; DELIMITER FLUSH ONE EXTRA LINE. IF(LINE(LSTCHR).GE.ICHAR(':').AND. 1 LINE(LSTCHR).LE.ICHAR('?'))THEN NNV=(LINE(LSTCHR))-57 C SKIP LINES BASED ON DELIMITER: C : = 1 SKIP C ; = 2 SKIPS C < = 3 SKIPS C = = 4 SKIPS C > = 5 SKIPS C ? = 6 SKIPS DO 3342 N=1,NNV 3342 CALL DTR$CONTINUE(DAB) END IF C GET STRING BACK C COPY MSG_BUFF BACK INTO CELL GIVEN C ID1,ID2 ADDRESS CELL. IFVLD=-1 C FLAG AS TEXT CALL FVLDST(ID1,ID2,IFVLD) C IRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRX) CALL WRKFIL(IRX,LBUF,0) C READ MEMORY ARRAY, MODIFY, THEN WRITE IT DO 233 N=1,110 233 LBUF(N)=0 DO 234 N=1,109 234 LBUF(N)=MSGBUF(N) C NULL OUT TRAILING BLANKS PRIOR TO STORING TEXT IN SHEET DO 235 N=1,109 NN=110-N IF(LBUF(NN).GT.32)GOTO 236 LBUF(NN)=0 235 CONTINUE 236 CONTINUE CALL WRKFIL(IRX,LBUF,1) XAC=1. C FLAG SUCCESSFUL GETTING OF MESSAGE BY RETURNING 1 IN % ACCUMULATOR. C LEAVE VALUE AT THIS CELL ALONE. 237 CALL DTR$CONTINUE(DAB) C FLUSH ANY EXTRA LINES OF MESSAGES IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 237 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 237 GOTO 9999 300 CONTINUE CALL SCMP(LINE,%REF('RPV'),3,ICODE) IF(ICODE.NE.1)GOTO 400 C FIRST ISOLATE CELL NAME LO=4 LHI=20 LSTCHR=20 CALL VARSCN(LINE,LO,LHI,LSTCHR,ID1,ID2,IVLD) IF(IVLD.EQ.0)GOTO 9990 C JUST SKIP COMMA, SO IT REALLY CAN BE ANY DELIMITER IF(LINE(LSTCHR).LE.32)THEN IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 340 C IF WE CAN'T GO TO SEND THE REPLY, NULL OUT COMMAND LINE LINE(LSTCHR+1)=32 LINE(LSTCHR+2)=0 ENDIF DO 310 N=1,60 NN=N M=LINE(LSTCHR+N) C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 311 C NNN=N LINEC(N:N)=CHAR(M) 310 CONTINUE 311 CONTINUE LINEC(NN:NN)=CHAR(32) XAC=0. C REPLY WITH VALUE. C THIS USES VALUE IN CELL FOR REPLY. C SINCE DTR EXPECTS TEXT, USE DISPLAY FORMAT IN CELL TO CONVERT THE C VALUE TO TEXT CHARACTERS. CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 320 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 330 IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 340 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 320 CONTINUE 330 CONTINUE CALL DTR$CONTINUE(DAB) IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 320 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 330 IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 340 GOTO 9999 340 CONTINUE C WAITING FOR DTR$PUT_VALUE CALL. GO GET VALUE AND CONVERT AND SHOVE C OUT. CALL XVBLGT(ID1,ID2,TMP) C TMP IS REAL*8 C NOW HAVE VALUE IN CELL (DEFAULT IS 0. IF CELL NOT INITIALIZED) C IRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRX) CALL WRKFIL(IRX,LBUF,0) C READ IN FORMULA BUFFER TO ALLOW US TO GET FORMAT TO USE. DO 341 N=1,9 K=LBUF(119+N) IF(K.LT.32)K=32 342 LBUF(119+N)=K 341 CONTINUE FMTBF='(' // FMTB // ')' C STASH FORMAT BUFFER IN THERE C WE ALREADY MADE SURE IT HAS ALL SPACES OR FORMAT DATA WRITE(SCRBUF,FMTBF,ERR=348)TMP C *****************&&&&&&&&& CALL DTR$PUT_VALUE(DAB,SCRBUF) XAC=1. IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 320 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 330 C FLUSH OUT THE REST 348 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) 400 CONTINUE CALL SCMP(LINE,%REF('RPF'),3,ICODE) C REPLY FROM FORMULA IF(ICODE.NE.1)GOTO 500 C FIRST ISOLATE CELL NAME LO=4 LHI=20 LSTCHR=20 CALL VARSCN(LINE,LO,LHI,LSTCHR,ID1,ID2,IVLD) IF(IVLD.EQ.0)GOTO 9990 C JUST SKIP COMMA, SO IT REALLY CAN BE ANY DELIMITER IF(LINE(LSTCHR).LE.32)THEN IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 440 C IF WE CAN'T GO TO SEND THE REPLY, NULL OUT COMMAND LINE LINE(LSTCHR+1)=32 LINE(LSTCHR+2)=0 ENDIF DO 410 N=1,60 NN=N M=LINE(LSTCHR+N) C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 411 C NNN=N LINEC(N:N)=CHAR(M) 410 CONTINUE 411 CONTINUE LINEC(NN:NN)=CHAR(32) XAC=0. C REPLY FROM FORMULA SO WILL LATER GET REPLY FROM FORMULA TEXT RATHER C THAN CURRENT VALUE. CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 420 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 430 IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 440 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 420 CONTINUE 430 CONTINUE CALL DTR$CONTINUE(DAB) C FLUSH ALL EXTRA MESSAGES IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 420 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 430 IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 440 GOTO 9999 440 CONTINUE C WAITING FOR DTR$PUT_VALUE CALL. GO EMIT FORMULA (UP TO 80 CHARACTERS C ANYHOW...) C IRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRX) CALL WRKFIL(IRX,LBUF,0) C READ IN FORMULA BUFFER TO ALLOW US TO GET FORMAT TO USE. SCRBUF=' ' DO 441 N=1,79 K=LBUF(N) IF(K.LT.32)GOTO 443 442 SCRBUF(N:N)=CHAR(K) 441 CONTINUE 443 CONTINUE C SEND OUT THE REPLY CALL DTR$PUT_VALUE(DAB,SCRBUF) XAC=1. IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 420 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 430 C FLUSH OUT THE REST 448 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C 500 CONTINUE C ENABLE/DISABLE FOR DTR FUNCTIONS C SETTING DTRENA TO -1 IMPLIES DISABLE FUNCTIONS CALL SCMP(LINE,%REF('ENA'),3,ICODE) IF(ICODE.NE.1)GOTO 600 DTRENA=1 GOTO 9999 600 CONTINUE CALL SCMP(LINE,%REF('DIS'),3,ICODE) IF(ICODE.NE.1)GOTO 700 DTRENA=-1 GOTO 9999 700 CONTINUE GOTO 9999 9990 RETCD=3 C ERROR RETURN 9999 RETURN END SUBROUTINE DTRFCT(LINE,RETCD) INTEGER*2 RETCD LOGICAL*1 LINE(80) LOGICAL *1 LINECL(82) CHARACTER*62 LINEC EQUIVALENCE(LINEC,LINECL(1)) INTEGER*2 DTRENA COMMON/DTRCMN/DTRENA INCLUDE 'VKLUGPRM.FTN' 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. LOGICAL*1 AVBLS(20,27),WRK(128),VBLS(8,RRWP,RCLP) INTEGER*2 TYPE(RRWP,RCLP),VLEN(9) REAL*8 XAC,XVBLS(RRWP,RCLP) REAL*8 TAC,UAC,VAC,WAC,YAC REAL*8 TMP INTEGER*4 JVBLS(2,RRWP,RCLP) EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25)) 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 INTEGER*2 XTNCNT,XTCFG,IPSET LOGICAL*1 XTNCMD(80) INTEGER*2 FORMFG,RCFGX,PZAP,RCONE INTEGER*2 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6 COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6 INTEGER*2 RRWACT,RCLACT COMMON/RCLACT/RRWACT,RCLACT COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS. C (IMPLEMENT FOR VAX ONLY) INTEGER KALKIT COMMON/VARYIT/KALKIT C ARGUMENTS COME IN IN ARGUMENTS IN LINE C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED... INTEGER*2 PROW,PCOL,DROW,DCOL,DRWV,DCLV COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV DIMENSION NRDSP(DRW,DCL),NCDSP(DRW,DCL) COMMON/D2R/NRDSP,NCDSP C ADD DATATRIEVE DATA STMTS HERE C *** c c FORTRAN DATATRIEVE Access Block c LOGICAL*1 DAB$B_BID, DAB$B_BLN, DAB$B_VER_LETTER, DAB(100) INTEGER*2 DAB$W_MSG_BUF_LEN, DAB$W_MSG_LEN, 1 DAB$W_AUX_BUF_LEN, DAB$W_AUX_LEN, 2 DAB$W_IDI, DAB$W_STATE, DAB$W_REC_LENGTH, 3 DAB$W_VERSION, DAB$W_LEVEL, DAB$W_BASE_LEVEL, 4 DAB$W_UDK_INDEX, DAB$W_COLUMNS_PAGE, 5 DAB$W_TT_CHANNEL LOGICAL*4 DAB$A_MSG_BUF, DAB$A_AUX_BUF, 1 DAB$L_CONDITION, DAB$L_FLAGS, DAB$L_OPTIONS COMMON /DAB_COMMON/ 1 DAB$B_BID, 2 DAB$B_BLN, 3 DAB$L_CONDITION, 4 DAB$A_MSG_BUF, 5 DAB$W_MSG_BUF_LEN, 6 DAB$W_MSG_LEN, 7 DAB$A_AUX_BUF, 8 DAB$W_AUX_BUF_LEN, 9 DAB$W_AUX_LEN, 1 DAB$W_IDI, 2 DAB$W_STATE, 3 DAB$L_FLAGS, 4 DAB$L_OPTIONS, 5 DAB$W_REC_LENGTH, 6 DAB$W_VERSION, 7 DAB$W_LEVEL, 8 DAB$B_VER_LETTER, 9 DAB$W_BASE_LEVEL, 1 DAB$W_UDK_INDEX, 2 DAB$W_COLUMNS_PAGE, 3 DAB$W_TT_CHANNEL EQUIVALENCE (DAB, DAB$B_BID) INTEGER DTR$K_STL_CMD, DTR$K_STL_PRMPT, DTR$K_STL_LINE, 1 DTR$K_STL_MSG, DTR$K_STL_PGET, DTR$K_STL_PPUT, 2 DTR$K_STL_CONT, DTR$K_STL_UDK, DTR$K_STL_END_UDK PARAMETER (DTR$K_STL_CMD=1, 1 DTR$K_STL_PRMPT=2, 2 DTR$K_STL_LINE=3, 3 DTR$K_STL_MSG=4, 4 DTR$K_STL_PGET=5, 5 DTR$K_STL_PPUT=6, 6 DTR$K_STL_CONT=7, 7 DTR$K_STL_UDK=8, 8 DTR$K_STL_END_UDK=9) INTEGER DTR$K_SEMI_COLON_OPT, DTR$K_UNQUOTED_LIT, 1 DTR$K_SYNTAX_PROMPT, DTR$K_IMMED_RETURN, 2 DTR$K_FORMS_ENABLE, DTR$K_VERIFY, DTR$K_CONTEXT_SEARCH, 3 DTR$K_HYPHEN_DISABLED, DTR$K_MORE_COMMANDS, DTR$K_ABORT, 4 DTR$K_LOCK_WAIT PARAMETER (DTR$K_SEMI_COLON_OPT=1, 1 DTR$K_UNQUOTED_LIT=16, 2 DTR$K_SYNTAX_PROMPT=32, 3 DTR$K_IMMED_RETURN=64, 4 DTR$K_FORMS_ENABLE=128, 5 DTR$K_VERIFY=256, 6 DTR$K_CONTEXT_SEARCH=2048, 7 DTR$K_HYPHEN_DISABLED=4096, 8 DTR$K_MORE_COMMANDS=8192, 9 DTR$K_ABORT=16384, 1 DTR$K_LOCK_WAIT=32768) INTEGER DTR$M_OPT_CMD, DTR$M_OPT_PRMPT, DTR$M_OPT_LINE, 1 DTR$M_OPT_MSG, DTR$M_OPT_PGET, DTR$M_OPT_PPUT, 2 DTR$M_OPT_CONT, DTR$M_OPT_UDK, DTR$M_OPT_DTR_UDK, 3 DTR$M_OPT_END_UDK, DTR$M_OPT_UNWIND, 4 DTR$M_OPT_CONTROL_C, DTR$M_OPT_STARTUP, 5 DTR$M_OPT_FOREIGN, DTR$M_OPT_BANNER, DTR$M_OPT_REMOVE_CTLC PARAMETER (DTR$M_OPT_CMD=1, 1 DTR$M_OPT_PRMPT=2, 2 DTR$M_OPT_LINE=4, 3 DTR$M_OPT_MSG=8, 4 DTR$M_OPT_PGET=16, 5 DTR$M_OPT_PPUT=32, 6 DTR$M_OPT_CONT=64, 7 DTR$M_OPT_UDK=128, 8 DTR$M_OPT_DTR_UDK=256, 9 DTR$M_OPT_END_UDK=512, 1 DTR$M_OPT_UNWIND=1024, 2 DTR$M_OPT_CONTROL_C=2048, 3 DTR$M_OPT_STARTUP=4096, 4 DTR$M_OPT_FOREIGN=8192, 5 DTR$M_OPT_BANNER=16384, 6 DTR$M_OPT_REMOVE_CTLC=32768) INTEGER DTR$K_UDK_SET, DTR$K_UDK_SET_NO, DTR$K_UDK_SHOW, 1 DTR$K_UDK_STATEMENT, DTR$K_UDK_COMMAND PARAMETER (DTR$K_UDK_SET=1, 1 DTR$K_UDK_SET_NO=2, 2 DTR$K_UDK_SHOW=3, 3 DTR$K_UDK_STATEMENT=4, 4 DTR$K_UDK_COMMAND=5) INTEGER DTR$K_TOK_TOKEN, DTR$K_TOK_PICTURE, 1 DTR$K_TOK_FILENAME, DTR$K_TOK_COMMAND, 2 DTR$K_TOK_TEST_TOKEN PARAMETER (DTR$K_TOK_TOKEN=1, 1 DTR$K_TOK_PICTURE=2, 2 DTR$K_TOK_FILENAME=3, 3 DTR$K_TOK_COMMAND=4, 4 DTR$K_TOK_TEST_TOKEN=5) CHARACTER*232 MSG_BUFF CHARACTER*232 AUX_BUFF COMMON /DTR$BUFFERS/MSG_BUFF,AUX_BUFF EXTERNAL DTR$_SUCCESS CHARACTER*80 SCRBUF LOGICAL*1 LBUF(128) CHARACTER*9 FMTB EQUIVALENCE (FMTB,LBUF(120)) CHARACTER*11 FMTBF LOGICAL*1 IFVLD LOGICAL*1 MSGBUF(80) EQUIVALENCE(MSGBUF(1),MSG_BUFF) C *** C ********>>>>>>>><<<<<<<<******** RETCD=1 IF(DTRENA.LT.0)GOTO 9999 C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE DO 3332 N=1,76 NN=77-N IF(LINE(NN).GT.32)GOTO 3333 LINE(NN)=0 3332 CONTINUE 3333 CONTINUE C SPACE FILL ENTIRE ARRAY DO 3334 N=1,82 3334 LINECL(N)=32 RETCD=1 C HANDLE *U DBXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE C STARTS AFTER THE "DB" SO WE CAN DECODE IT. C *U DBCMD (COMMAND) PASSES COMMAND TO DTR FOR ACTION C HOWEVER THIS DOES NOT RETURN A VALUE. USE FOR C SETUP PURPOSES ONLY. C C INTERFACE DOCUMENTATION: C C *U DBCMD COMMAND C WILL PASS COMMAND AND FLUSH MESSAGES. C *U DBVAL COMMAND C WILL PASS COMMAND AND RETRIEVE CONTENTS OF C MESSAGE BUFFER AS VALUE IN % ACCUMULATOR C *U DBTXT CELL,COMMAND C WILL PASS COMMAND AND RETRIEVE MESSAGE BUFFER. C MESSAGE BUFFER WILL BE PLACED IN CELL NAMED C AS ASCII TEXT. C *U DBRPV CELL C WILL TAKE VALUE IN CELL AND USE AS A REPLY TO A C DTR QUERY (AS IN KEYBOARD INPUTS TO PROCEDURES). C *U DBRPT CELL C WILL TAKE TEXT IN CELL AND USE AS A REPLY TO A C DTR QUERY AS ABOVE. C C ALL THE ABOVE CALLS WILL BE ALSO IMPLEMENTED AS C DIRECT "DTRXXX" COMMANDS FOR COMMAND LEVEL USE. C C NO NEED TO INCLUDE ABILITY TO STORE COMMANDS IN CELLS C FOR EDITING SINCE {CELL CONSTRUCT PROVIDES THIS ALREADY. C (AND AT COMMAND LEVEL THE __{CELL CONSTRUCT DOES ALSO.) CALL SCMP(LINE,%REF('CMD'),3,ICODE) IF(ICODE.NE.1)GOTO 100 C *U DBCMD COMMAND C EXECUTE DTR COMMAND C CONSTRUCT A DESCRIPTOR... DO 10 N=1,60 NN=N M=LINE(4+N) C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 11 C NNN=N LINEC(N:N)=CHAR(M) 10 CONTINUE 11 CONTINUE LINEC(NN:NN)=CHAR(32) CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 20 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 20 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 20 CONTINUE CALL DTR$CONTINUE(DAB) IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 20 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 20 C JUST CONTINUE IF WE ONLY GOT A MESSAGE OR PRINT LINE HERE. c no provision for printing it and we normally want to avoid c prints of this anyway. GOTO 9999 100 CONTINUE CALL SCMP(LINE,%REF('VAL'),3,ICODE) IF(ICODE.NE.1)GOTO 200 LSKIP=(LINE(4))-57 IF(LSKIP.LT.0.OR.LSKIP.GT.9)LSKIP=0 IVV=4 IF(LINE(5).EQ.ICHAR('.'))THEN IVV=IVV+1 END IF DO 110 N=1,60 M=LINE(IVV+N) NN=N C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 111 C NNN=N LINEC(N:N)=CHAR(M) 110 CONTINUE 111 CONTINUE LINEC(NN:NN)=CHAR(32) CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 120 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 130 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 120 CONTINUE CALL DTR$CONTINUE(DAB) IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 120 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 130 GOTO 9999 130 CONTINUE IF(LSKIP.GT.0)THEN DO 3346 N=1,LSKIP 3346 CALL DTR$CONTINUE(DAB) C SKIP EXTRA PRINT LINES IF NEEDED TO DO SO END IF IF(IVV.GE.5)THEN IQ=0 DO 135 N=1,110 135 IF(MSGBUF(N).EQ.ICHAR('.'))IQ=1 IVVV=0 DO 138 N=1,80 IF(MSGBUF(NN).EQ.ICHAR(':'))IVVV=N+1 NN=81-N IF(MSGBUF(NN).GT.32)GOTO 139 138 CONTINUE 139 IF(IQ.EQ.0)MSGBUF(NN+1)=46 C 46 IS ASCII PERIOD C IF WE HAVE . AS FIRST CHAR OF COMMAND THEN C ADD DECIMAL TO END OF TEXT AND START TEXT AFTER THE : OF A C POSSIBLE LIST COMMAND. ONLY ADD THE DECIMAL IF NONE IS IN C THE STRING ALREADY AND ONLY SKIP COLON IF ONE EXISTS. IF(IVVV.GT.0)THEN K=1 DO 137 N=IVVV,NN+1 MSGBUF(K)=MSGBUF(N) K=K+1 137 CONTINUE DO 136 N=K,110 136 MSGBUF(K)=32 END IF END IF C GET VALUE BACK C FORTRAN-77 HACK. USE INTERNAL READ C GETS RESULT INTO % ACCUMULATOR. READ(MSG_BUFF,140,ERR=9990)XAC c use wide format to allow correct readin of many formats 140 FORMAT(D30.15) C LOOP BACK TO CLEAR ANY REMAINING READINS GOTO 120 C JUST CONTINUE IF WE ONLY GOT A MESSAGE OR PRINT LINE HERE. 200 CONTINUE CALL SCMP(LINE,%REF('TXT'),3,ICODE) IF(ICODE.NE.1)GOTO 300 c get cell name now and skip the comma after it... C *U DBTXT CELL,COMMAND C GETS REPLY INTO CELL. IF NO REPLY, CELL UNCHANGED. LO=4 LHI=20 LSTCHR=20 CALL VARSCN(LINE,LO,LHI,LSTCHR,ID1,ID2,IVLD) IF(IVLD.EQ.0)GOTO 9990 C JUST SKIP COMMA, SO IT REALLY CAN BE ANY DELIMITER IF(LINE(LSTCHR).LE.32)THEN IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 230 LINE(LSTCHR+1)=32 LINE(LSTCHR+2)=0 ENDIF DO 210 N=1,60 NN=N M=LINE(LSTCHR+N) C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 211 C NNN=N LINEC(N:N)=CHAR(M) 210 CONTINUE 211 CONTINUE LINEC(NN:NN)=CHAR(32) XAC=0. CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 220 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 230 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 220 CONTINUE CALL DTR$CONTINUE(DAB) IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 220 GOTO 9999 230 CONTINUE C IF(LINE(LSTCHR).EQ.ICHAR(';'))CALL DTR$CONTINUE(DAB) C SKIP ONE LINE IF WE SEE A ; AFTER CELL NAME INSTEAD OF COMMA. IF(LINE(LSTCHR).GE.ICHAR(':').AND. 1 LINE(LSTCHR).LE.ICHAR('?'))THEN NNV=(LINE(LSTCHR))-57 C SKIP LINES BASED ON DELIMITER: C : = 1 SKIP C ; = 2 SKIPS C < = 3 SKIPS C = = 4 SKIPS C > = 5 SKIPS C ? = 6 SKIPS DO 3342 N=1,NNV 3342 CALL DTR$CONTINUE(DAB) END IF C GET STRING BACK C COPY MSG_BUFF BACK INTO CELL GIVEN C ID1,ID2 ADDRESS CELL. IFVLD=-1 C FLAG AS TEXT CALL FVLDST(ID1,ID2,IFVLD) C IRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRX) CALL WRKFIL(IRX,LBUF,0) C READ MEMORY ARRAY, MODIFY, THEN WRITE IT DO 233 N=1,110 233 LBUF(N)=0 DO 234 N=1,80 234 LBUF(N)=MSGBUF(N) C NULL OUT TRAILING BLANKS PRIOR TO STORING TEXT IN SHEET DO 235 N=1,109 NN=110-N IF(LBUF(NN).GT.32)GOTO 236 LBUF(NN)=0 235 CONTINUE 236 CONTINUE CALL WRKFIL(IRX,LBUF,1) XAC=1. C FLAG SUCCESSFUL GETTING OF MESSAGE BY RETURNING 1 IN % ACCUMULATOR. C LEAVE VALUE AT THIS CELL ALONE. 237 CALL DTR$CONTINUE(DAB) C FLUSH ALL REMAINING MESSAGES... IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 237 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 237 GOTO 9999 300 CONTINUE CALL SCMP(LINE,%REF('RPV'),3,ICODE) IF(ICODE.NE.1)GOTO 400 C FIRST ISOLATE CELL NAME LO=4 LHI=20 LSTCHR=20 CALL VARSCN(LINE,LO,LHI,LSTCHR,ID1,ID2,IVLD) IF(IVLD.EQ.0)GOTO 9990 C JUST SKIP COMMA, SO IT REALLY CAN BE ANY DELIMITER IF(LINE(LSTCHR).LE.32)THEN IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 340 C MAKE CMD NULL IF NO COMMA THERE LINE(LSTCHR+1)=32 LINE(LSTCHR+2)=0 ENDIF DO 310 N=1,60 NN=N M=LINE(LSTCHR+N) C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 311 C NNN=N LINEC(N:N)=CHAR(M) 310 CONTINUE 311 CONTINUE LINEC(NN:NN)=CHAR(32) XAC=0. C REPLY WITH VALUE. C THIS USES VALUE IN CELL FOR REPLY. C SINCE DTR EXPECTS TEXT, USE DISPLAY FORMAT IN CELL TO CONVERT THE C VALUE TO TEXT CHARACTERS. CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 320 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 330 IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 340 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 320 CONTINUE 330 CONTINUE CALL DTR$CONTINUE(DAB) IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 320 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 330 IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 340 GOTO 9999 340 CONTINUE C WAITING FOR DTR$PUT_VALUE CALL. GO GET VALUE AND CONVERT AND SHOVE C OUT. CALL XVBLGT(ID1,ID2,TMP) C TMP IS REAL*8 C NOW HAVE VALUE IN CELL (DEFAULT IS 0. IF CELL NOT INITIALIZED) C IRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRX) CALL WRKFIL(IRX,LBUF,0) C READ IN FORMULA BUFFER TO ALLOW US TO GET FORMAT TO USE. DO 341 N=1,9 K=LBUF(119+N) IF(K.LT.32)K=32 342 LBUF(119+N)=K 341 CONTINUE FMTBF='(' // FMTB // ')' C STASH FORMAT BUFFER IN THERE C WE ALREADY MADE SURE IT HAS ALL SPACES OR FORMAT DATA WRITE(SCRBUF,FMTBF,ERR=348)TMP CALL DTR$PUT_VALUE(DAB,SCRBUF(1:45)) XAC=1. IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 320 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 330 C FLUSH OUT THE REST 348 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) 400 CONTINUE CALL SCMP(LINE,%REF('RPF'),3,ICODE) C REPLY FROM FORMULA IF(ICODE.NE.1)GOTO 500 C FIRST ISOLATE CELL NAME LO=4 LHI=20 LSTCHR=20 CALL VARSCN(LINE,LO,LHI,LSTCHR,ID1,ID2,IVLD) IF(IVLD.EQ.0)GOTO 9990 C JUST SKIP COMMA, SO IT REALLY CAN BE ANY DELIMITER IF(LINE(LSTCHR).LE.32)THEN IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 440 LINE(LSTCHR+1)=32 LINE(LSTCHR+2)=0 ENDIF DO 410 N=1,60 NN=N M=LINE(LSTCHR+N) C COPY CHARACTER ARRAY INTO STRING IF(M.LT.32)GOTO 411 C NNN=N LINEC(N:N)=CHAR(M) 410 CONTINUE 411 CONTINUE LINEC(NN:NN)=CHAR(32) XAC=0. C REPLY FROM FORMULA SO WILL LATER GET REPLY FROM FORMULA TEXT RATHER C THAN CURRENT VALUE. CALL DTR$COMMAND(DAB,LINEC(1:NN)) C CHECK STATUS IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 420 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 430 IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 440 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C LET DTR$DTR HANDLE MESSAGES AND SO ON UNTIL BACK AT C COMMAND STALLPOINT. NOTE THAT THIS TAKES CARE OF COMMANDS THAT C UNEXPECTEDLY CALL FOR MESSAGES OR INPUTS. GOTO 9999 420 CONTINUE 430 CONTINUE CALL DTR$CONTINUE(DAB) IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 420 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 430 IF (DAB$W_STATE.EQ.DTR$K_STL_PRMPT)GOTO 440 GOTO 9999 440 CONTINUE C WAITING FOR DTR$PUT_VALUE CALL. GO EMIT FORMULA (UP TO 80 CHARACTERS C ANYHOW...) C IRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRX) CALL WRKFIL(IRX,LBUF,0) C READ IN FORMULA BUFFER TO ALLOW US TO GET FORMAT TO USE. SCRBUF=' ' DO 441 N=1,79 K=LBUF(N) IF(K.LT.32)GOTO 443 NNN=N 442 SCRBUF(N:N)=CHAR(K) 441 CONTINUE 443 CONTINUE C SEND OUT THE REPLY CALL DTR$PUT_VALUE(DAB,SCRBUF(1:NNN)) XAC=1. IF (DAB$W_STATE.EQ.DTR$K_STL_MSG)GOTO 420 IF (DAB$W_STATE.EQ.DTR$K_STL_LINE)GOTO 430 C FLUSH OUT THE REST 448 CALL DTR$DTR(DAB,DTR$M_OPT_CMD) C 500 CONTINUE GOTO 9999 9990 RETCD=3 C ERROR RETURN 9999 RETURN END