home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / cdccyber / cd3ker.src < prev    next >
Text File  |  2020-01-01  |  193KB  |  7,283 lines
  1. *COMDECK COMCKER
  2. C$    LIST(S=COMLIS)
  3.  
  4. ****  COMCKER - KERMIT SYMBOL DEFINITIONS.
  5. *
  6.  
  7. **    FILE I/O DEFINITIONS.
  8. *
  9.       PARAMETER (STDIN =1)
  10.       PARAMETER (STDOUT=2)
  11.  
  12. **    ASCII CHARACTERS.
  13. *
  14.       PARAMETER (SOH=1)
  15.       PARAMETER (ETX=3)
  16.       PARAMETER (BELL=7)
  17.       PARAMETER (TAB=9)
  18.       PARAMETER (LF=10)
  19.       PARAMETER (CR=13)
  20.       PARAMETER (DC4=20)
  21.       PARAMETER (BLANK=32)
  22.       PARAMETER (MINUS=45)
  23.       PARAMETER (COLON=58)
  24.       PARAMETER (QMARK=63)
  25.       PARAMETER (DEL=127)
  26.       PARAMETER (NEL=O"3777")
  27.       PARAMETER (NULL=O"4000")
  28.  
  29. **    MISCELLANEOUS.
  30. *
  31.       PARAMETER (OK=1)
  32.       PARAMETER (EOF=-1)
  33.       PARAMETER (ERROR=-2)
  34.       PARAMETER (ON=1, OFF=0)
  35.       PARAMETER (YES=1, NO=0)
  36.  
  37. **    DISK FILE CHARACTER SETS.
  38. *
  39.       PARAMETER (CSNONE=0, CSDSP=1, CS812=2, CS612=3, CSBIN=4, CSTXP=5)
  40.  
  41. **    PROTOCOL DEFINITIONS.
  42. *
  43.       PARAMETER (UNKNOWN=0, FULLDUP=1, HALFDUP=2)
  44.       PARAMETER (NORMAL=0, TXP=1)
  45.  
  46.       PARAMETER (MAXINIT=15)
  47.       PARAMETER (MAXTRY=10)
  48.       PARAMETER (IPKSIZE=94)
  49. *     MAX LONG PACKET SIZE.  DON'T RAISE ABOVE 4000.
  50.       PARAMETER (LPKSIZE=1000)
  51.       PARAMETER (ITIMOUT=10)
  52.       PARAMETER (IPADCT=0)
  53.       PARAMETER (IPADCH=0)
  54.       PARAMETER (IEOLCH=13)
  55.       PARAMETER (ICQUOTE=35)
  56.       PARAMETER (I8QUOTE=38)
  57.       PARAMETER (ICHKTYP=49)
  58.       PARAMETER (IRPTPFX=126)
  59.  
  60. *     INIT CAPABILITY BIT MASKS
  61.  
  62.       PARAMETER (CAPAS1 = 32)
  63.       PARAMETER (CAPAS2 = 16)
  64.       PARAMETER (CAPAS3 = 8)
  65.       PARAMETER (CAPAS4 = 4)
  66.       PARAMETER (CAPAS5 = 2)
  67.       PARAMETER (CAPAS6 = 1)
  68.  
  69. **    PACKET TYPES.
  70. *
  71.       PARAMETER (A=65)
  72.       PARAMETER (B=66)
  73.       PARAMETER (C=67)
  74.       PARAMETER (D=68)
  75.       PARAMETER (E=69)
  76.       PARAMETER (F=70)
  77.       PARAMETER (G=71)
  78.       PARAMETER (EYE=73)
  79.       PARAMETER (L=76)
  80.       PARAMETER (N=78)
  81.       PARAMETER (P=80)
  82.       PARAMETER (R=82)
  83.       PARAMETER (S=83)
  84.       PARAMETER (X=88)
  85.       PARAMETER (Y=89)
  86.       PARAMETER (Z=90)
  87.  
  88. **    PACKET ERROR DEFINITIONS.
  89. *
  90.       PARAMETER (TOOMANY=O"1000")
  91.       PARAMETER (INVALID=O"2000")
  92.       PARAMETER (SEQERR=O"4000")
  93.       PARAMETER (LCLFILE=O"10000")
  94.       PARAMETER (NOTLCL=O"20000")
  95.       PARAMETER (INVFN=O"40000")
  96.       PARAMETER (SRVCMD=O"100000")
  97.       PARAMETER (MICERR=O"200000")
  98.       PARAMETER (INTRPT=O"400000")
  99.       PARAMETER (SENDING=O"100")
  100.       PARAMETER (READING=O"200")
  101.       PARAMETER (INITERR=1)
  102.       PARAMETER (FILERR=2)
  103.       PARAMETER (DATAERR=4)
  104.       PARAMETER (EOFERR=O"10")
  105.       PARAMETER (BRKERR=O"20")
  106.  
  107.  
  108. ***   KERMIT SAVED COMMON BLOCK HEADER.
  109. *
  110. *     ALL COMMON BLOCKS TO BE SAVED WHEN EXECUTING MONITOR
  111. *     COMMANDS MUST BE PLACED BETWEEN /HEADER/ AND /TRAILER/
  112. *
  113.       COMMON /HEADER/ HEADER
  114.  
  115.  
  116. **    KERMIT COMMAND PROCESSOR COMMON BLOCK.
  117. *
  118.       PARAMETER (BINARY=0, TEXT=1)
  119.       COMMON /CMD/ AUTORET
  120.       COMMON /CMD/ CINDEX
  121.       LOGICAL CMDLOCF
  122.       COMMON /CMD/ CMDFD, CMDLOCF
  123.       CHARACTER CMDLFN*10
  124.       COMMON /CMDC/ CMDLFN
  125.  
  126. **    KERMIT SEND-INIT PACKETS.
  127. *
  128. *     DO NOT ALLOCATE ANY STORAGE BETWEEN SPKSIZE AND DSYNC!
  129.  
  130. *     OUTGOING - WHAT WE WANT
  131.  
  132.       COMMON /PACKET/ SPKSIZE
  133.       COMMON /PACKET/ STIMOUT
  134.       COMMON /PACKET/ SPADCT
  135.       COMMON /PACKET/ SPADCH
  136.       COMMON /PACKET/ SEOLCH
  137.       COMMON /PACKET/ SCQUOTE
  138.       COMMON /PACKET/ S8QUOTE
  139.       COMMON /PACKET/ SCHKTYP
  140.       COMMON /PACKET/ SRPTPFX
  141.       COMMON /PACKET/ SUNUSED(2)
  142.       COMMON /PACKET/ SSYNC
  143.  
  144. *     INCOMING - WHAT THE OTHER KERMIT WANTS  (SET BY OTHER KERMIT)
  145.  
  146.       COMMON /PACKET/ RPKSIZE
  147.       COMMON /PACKET/ RTIMOUT
  148.       COMMON /PACKET/ RPADCT
  149.       COMMON /PACKET/ RPADCH
  150.       COMMON /PACKET/ REOLCH
  151.       COMMON /PACKET/ RCQUOTE
  152.       COMMON /PACKET/ R8QUOTE
  153.       COMMON /PACKET/ RCHKTYP
  154.       COMMON /PACKET/ RRPTPFX
  155.       COMMON /PACKET/ RUNUSED(2)
  156.       COMMON /PACKET/ RSYNC
  157.  
  158. *     INCOMING - WHAT THE OTHER KERMIT WANTS  (DEFAULTS)
  159.  
  160.       COMMON /PACKET/ DPKSIZE
  161.       COMMON /PACKET/ DTIMOUT
  162.       COMMON /PACKET/ DPADCT
  163.       COMMON /PACKET/ DPADCH
  164.       COMMON /PACKET/ DEOLCH
  165.       COMMON /PACKET/ DCQUOTE
  166.       COMMON /PACKET/ D8QUOTE
  167.       COMMON /PACKET/ DCHKTYP
  168.       COMMON /PACKET/ DRPTPFX
  169.       COMMON /PACKET/ DUNUSED(2)
  170.       COMMON /PACKET/ DSYNC
  171.  
  172.  
  173. **    KERMIT PROTOCOL COMMON BLOCK.
  174. *
  175.       COMMON /PROTO/ PACKET(LPKSIZE+10)
  176.       COMMON /PROTO/ RECPACK(LPKSIZE+10)
  177.       COMMON /PROTO/ FILESTR(IPKSIZE)
  178.       COMMON /PROTO/ DELAYFP
  179.       COMMON /PROTO/ DUPLEX
  180.       COMMON /PROTO/ FFD
  181.       COMMON /PROTO/ FILMODE
  182.       COMMON /PROTO/ TXTMODE
  183.       COMMON /PROTO/ INITDUP
  184.       COMMON /PROTO/ MAXRINI
  185.       COMMON /PROTO/ MAXRTRY
  186.       COMMON /PROTO/ NUMTRY
  187.       COMMON /PROTO/ PACKNUM
  188.       COMMON /PROTO/ PSIZE
  189.       COMMON /PROTO/ REPCH
  190.       COMMON /PROTO/ Q8CH
  191.       COMMON /PROTO/ RDELAY
  192.       COMMON /PROTO/ STATE
  193.  
  194.  
  195. **    STORAGE FOR STATISTICS.
  196. *
  197.       COMMON /PROTO/ ABORTYP
  198.       COMMON /PROTO/ ENDTIM
  199.       COMMON /PROTO/ RCHCNT
  200.       COMMON /PROTO/ RCHOVRH
  201.       COMMON /PROTO/ SCHCNT
  202.       COMMON /PROTO/ SCHOVRH
  203.       COMMON /PROTO/ STARTIM
  204.  
  205.  
  206. **    DEBUG COMMON BLOCK.
  207. *
  208.       PARAMETER (DBGOFF=0, DBGSTAT=1, DBGPACK=2, DBGALL=3)
  209.       COMMON /DEBUG/ DEBUG
  210.       COMMON /DEBUG/ DEBUGFD
  211.       COMMON /DEBUG/ DEBUGFN(8)
  212.  
  213.  
  214. **    ASCII STRING MESSAGE.
  215. *
  216.       INTEGER ERRMSG(IPKSIZE), MICMSG(IPKSIZE)
  217.       COMMON /MSG/ ERRMSG, MICMSG
  218.  
  219.  
  220. ***   FILE I/O COMMON BLOCK DEFINITIONS.
  221. *
  222.       PARAMETER (MAXFILE=4)
  223.  
  224. **    CIO RELATED PARAMETERS.
  225. *
  226. *     CIOBUFL = CIO BUFFER LENGTH.
  227. *     FETL    = FET LENGTH IN WORDS.
  228. *     MAXWD   = LINE SIZE IN WORDS; MUST BE AN EVEN NUMBER.
  229.  
  230.       PARAMETER (CIOBUFL=LPKSIZE/5+20, FETL=6, MAXWD=LPKSIZE/5+20)
  231.       PARAMETER (CLOSED=0, RD=1, WR=2, CREATE=3)
  232.  
  233.       CHARACTER*10 FNAME(MAXFILE)
  234.       COMMON /FILEIOC/ FNAME
  235.  
  236.       BOOLEAN CIOBUFF(CIOBUFL,MAXFILE)
  237.       BOOLEAN FCHBUF(MAXWD,MAXFILE)
  238.       BOOLEAN FETS(0:FETL-1,MAXFILE)
  239.       INTEGER FCSET(MAXFILE)
  240.       INTEGER FMODE(MAXFILE)
  241.       INTEGER FNWDS(MAXFILE)
  242.       INTEGER FUNGTCH(MAXFILE)
  243.       INTEGER FWPTR(MAXFILE)
  244.       INTEGER FWSHFT(MAXFILE)
  245.       LOGICAL CTDEV(MAXFILE)
  246.       LOGICAL FEOF(MAXFILE)
  247.       LOGICAL LOCFILE
  248.       LOGICAL WAITPAK
  249.  
  250.       COMMON /FILEIO/ CIOBUFF
  251.       COMMON /FILEIO/ CTDEV
  252.       COMMON /FILEIO/ FCHBUF
  253.       COMMON /FILEIO/ FCSET
  254.       COMMON /FILEIO/ FEOF
  255.       COMMON /FILEIO/ FETS
  256.       COMMON /FILEIO/ FMODE
  257.       COMMON /FILEIO/ FNWDS
  258.       COMMON /FILEIO/ FUNGTCH
  259.       COMMON /FILEIO/ FWPTR
  260.       COMMON /FILEIO/ FWSHFT
  261.       COMMON /FILEIO/ LOCFILE
  262.       COMMON /FILEIO/ WAITPAK
  263.  
  264.  
  265. ***   KERMIT SAVED COMMON BLOCK TRAILER.
  266. *
  267.       COMMON /TRAILER/ TRAILER
  268.  
  269.  
  270. **    MESSAGE COMMON BLOCK.
  271. *
  272.       CHARACTER*74 HLPASCH
  273.       CHARACTER*37 HLPDBFN
  274.       CHARACTER*42 HLPDLFP
  275.       CHARACTER*29 HLPIPRC
  276.       CHARACTER*34 HLPPADL
  277.       CHARACTER*24 HLPPLEN
  278.       CHARACTER*21 HLPPRTR
  279.       CHARACTER*41 HLPRDEL
  280.       CHARACTER*13 HLPSNFN
  281.       CHARACTER*43 HLPTIMO
  282.       CHARACTER VERSION*47
  283.       INTEGER VERSDAT, VERSSTR(11)
  284.  
  285.       COMMON /MESSAGE/ HLPASCH
  286.       COMMON /MESSAGE/ HLPDBFN
  287.       COMMON /MESSAGE/ HLPDLFP
  288.       COMMON /MESSAGE/ HLPIPRC
  289.       COMMON /MESSAGE/ HLPPADL
  290.       COMMON /MESSAGE/ HLPPLEN
  291.       COMMON /MESSAGE/ HLPPRTR
  292.       COMMON /MESSAGE/ HLPRDEL
  293.       COMMON /MESSAGE/ HLPSNFN
  294.       COMMON /MESSAGE/ HLPTIMO
  295.       COMMON /MESSAGE/ VERSION
  296.       COMMON /BMESAGE/ VERSDAT, VERSSTR
  297.  
  298.  
  299. **    CHARACTER SET CONVERSION TABLES.
  300. *
  301. *     ASC612 = ASCII TO 6/12.
  302. *     DPCTBL = ASCII TO DISPLAY CODE.
  303. *     LASCII = DISPLAY CODE TO LOWER CASE ASCII.
  304. *     SX1274 = 6/12 "74" ESCAPE CHARACTERS TO ASCII.
  305. *     SX1276 = 6/12 "76" ESCAPE CHARACTERS TO ASCII.
  306. *     UASCII = DISPLAY CODE TO UPPER CASE ASCII.
  307. *
  308. *     THE TABLES ARE MODIFIED FOR 63 CHARACTER SET BY ROUTINE 'FIXCTAB'
  309. *     AT INITIALIZATION TIME IF REQUIRED.
  310. *
  311.  
  312.       BOOLEAN ASC612(0:127)
  313.       BOOLEAN DPCTBL(0:127)
  314.       BOOLEAN LASCII(0:63)
  315.       BOOLEAN SX1274(0:63)
  316.       BOOLEAN SX1276(0:63)
  317.       BOOLEAN UASCII(0:63)
  318.  
  319.       COMMON /CHARCOM/ ASC612
  320.       COMMON /CHARCOM/ DPCTBL
  321.       COMMON /CHARCOM/ LASCII
  322.       COMMON /CHARCOM/ SX1274
  323.       COMMON /CHARCOM/ SX1276
  324.       COMMON /CHARCOM/ UASCII
  325.  
  326. C$    LIST(S=1)
  327. *COMDECK COMXKER
  328. C$    LIST(S=1)
  329.  
  330. ****  COMXKER - KERMIT STATEMENT FUNCTION DEFINITIONS.
  331. *
  332.  
  333.       UNCHAR(ASCCH) = ASCCH - BLANK
  334.       TOCHAR(ASCCH) = ASCCH + BLANK
  335.       CTL(ASCCH) = XOR(ASCCH,O"100")
  336.  
  337. C$    LIST(S=1)
  338. *DECK KERMIT
  339.           IDENT  KERMIT
  340. *IF -DEF,DEBUG,1
  341.           LCC    OVERLAY(KERMIT,0,0,OV=15)
  342. *IF DEF,DEBUG,1
  343.           LCC    OVERLAY(KERMIT,0,0)
  344.           ENTRY  KERMIT
  345.           LDSET  EPT=KERMIT
  346.           SYSCOM B1
  347.           SST
  348.  KERMIT   TITLE  KERMIT - MICRO COMPUTER FILE EXCHANGE/KERMIT PROTOCOL.
  349.           COMMENT MICRO COMPUTER FILE EXCHANGE/KERMIT PROTOCOL.
  350.  KERMIT   SPACE  4,10
  351. *****     KERMIT - MICRO COMPUTER FILE EXCHANGE/KERMIT PROTOCOL.
  352. *
  353. *         KERMIT IS A FILE SHIPPING PROGRAM USED BY MICRO COMPUTERS TO
  354. *         TRANSFER FILES TO/FROM ANOTHER COMPUTER.
  355.  KERMIT   SPACE  4,10
  356. ***       MICRO COMPUTER FILE INTERCHANGE/KERMIT PROTOCOL.
  357. *
  358. *         THIS VERSION IS FOR USE UNDER NOS 2.
  359.  
  360.  KERMIT   SPACE  4,10
  361. **        MAIN PROGRAM.
  362.  
  363.  KERMIT   RJ     =XKERMAIN
  364.  
  365.           END    KERMIT
  366.       SUBROUTINE KERMAIN
  367.  
  368. ***   KERMIT - A CYBER FILE TRANSFER PROGRAM USING THE KERMIT PROTOCOL
  369. *
  370. *     THIS PROGRAM MAY NOT BE SOLD FOR PROFIT.
  371. *
  372. *     MODIFICATIONS: 
  373. *
  374. *     3.3   05/19/87  STEPHEN G. ROSEMAN, LEHIGH UNIVERSITY
  375. *
  376. *        1. CHANGE RECEIVE FILE NAMING.  INSTEAD OF FIRST 7 VALID
  377. *           CHARACTERS, TAKE UP TO 3 FROM THE EXTENSION, IF FOUND.  THUS
  378. *           ABCEFGH.BIN > ABCDBIN.
  379. *
  380. *        2. FIX SPOTS WHERE SUBSCRIPT CHECKING FAILED.  DIDN'T CAUSE ANY
  381. *           PROBLEMS, BUT IT WAS ANNOYING WHEN USING FTN5,DB.
  382. *
  383. *        3. BROKE UP SERVER FUNCTIONS TO SECONDARY OVERLAYS TO REDUCE
  384. *           THE SIZE OF THE SERVER.
  385. *
  386. *        4. FIXED ERROR IN SEND COMMAND, YOU COULDN'T PUT P: OR L: ON
  387. *           FRONT OF 6 OR 7 CHARACTER FILENAME.
  388. *
  389. *        5. ADDED 'TAKE' COMMAND AND INITIAL READ FROM THE FILE
  390. *           'KERMINI'.  ALLOWS LOCAL OR PERMANENT TAKE/KERMINI FILES.
  391. *
  392. *        6. BE SURE TO UNLOAD CORRECT FILE IF RECEIVE WAS ABORTED.
  393. *           FIX VARIOUS MINOR PROBLEMS WITH INTERRUPTED TRANSFERS.
  394. *
  395. *        7. ALLOW CTRL/C TO CANCEL THE PROTOCOL IF ENTERED AS THE FIRST
  396. *           CHARACTER OF AN INPUT LINE.
  397. *
  398. *        8. USE TRANSPARENT MODE FOR SEND MODE, AS WELL AS RECEIVE AND
  399. *           SERVER MODES.
  400. *
  401. *     3.2   02/03/87  STEPHEN G. ROSEMAN, LEHIGH UNIVERSITY
  402. *           IMPLEMENTED UNDER NOS 2.5.1, LEVEL 664.  SHOULD WORK AT
  403. *           PREVIOUS NOS LEVELS.
  404. *
  405. *        FEATURE ADDITIONS: 
  406. *
  407. *        1. ADD WAIT-FOR-INPUT CODE, PREVENTING A NEED TO SWAPOUT BEFORE
  408. *           EACH TERMINAL READ IF THE PACKET INPUT ISN'T THERE YET.
  409. *
  410. *        2. ALLOW KERMIT TO TIMEOUT IF PACKET DOESN'T COME FROM THE
  411. *           OTHER SIDE IN TIME.
  412. *
  413. *        3. ALLOW WILDCARD FILE SEND AND SERVER-SEND.  SEARCHES FIRST
  414. *           FOR MATCH IN LOCAL DISK FILES; IF NONE FOUND, IT SEARCHES
  415. *           THE USER'S PERM FILE CATALOG.  L: AND P: ALLOW EXPLICIT
  416. *           SPECIFICATION OF LOCAL OR PERMANENT FILE.  'SEND' DISPLAYS
  417. *           FILE TYPE TO USER (LOCAL OR PERMANENT).
  418. *
  419. *        4. PUT 63 CHARACTER SET SUPPORT BACK IN.  CONVERSION TABLES
  420. *           ARE UPDATED AT EXECUTION TIME, SO THERE ARE NO INSTALLATION
  421. *           OPTIONS TO FORGET.
  422. *
  423. *        5. FIXED TRANSFER STATISTICS TO START TIMING AFTER RECEIVING
  424. *           FIRST PACKET FROM THE MICRO.  WHY LOOK BAD JUST BECAUSE THE
  425. *           USER WAS SLOW AT ENTERING THE COMMANDS ON THE MICRO?
  426. *
  427. *        6. MADE SEVERAL CHANGES TO VERSION DISPLAY LINE.  DISPLAY
  428. *           VERSION LINE WHEN STARTING KERMIT.
  429. *
  430. *        7. ADDED LONG PACKET SUPPORT.  CAN SEND AND RECEIVE PACKETS UP
  431. *           TO 4000 CHARACTERS (RELEASE VALUE = 1000).
  432. *
  433. *        8. MODIFIED 'HELP' COMMAND TO READ TEXT FROM A PERMANENT FILE
  434. *           AND DISPLAY ONLY 22 LINES/PAGE.  UPDATE HELP TEXT FOR NEW
  435. *           FEATURES.
  436. *
  437. *        9. ALLOWED CONTROL/T TO ABORT KERMIT SERVER OR RECEIVE MODE.
  438. *
  439. *        10. FIXED ERROR IN REPEAT-PREFIXED FILENAME RECEPTION.
  440. *
  441. *        11. ADDED DIR COMMAND AND REMOTE DIR SERVER COMMAND SUPPORT.
  442. *
  443. *        12. CHANGE TERMINAL OUTPUT TO 'WRITE', INSTEAD OF 'WRITER'.
  444. *            ENSURE 0 BYTE TERMINATOR WRITTEN ON EACH TERMINAL WRITE.
  445. *
  446. *        13. MAKE AUTO CHARACTER SET RECOGNITION ACTUALLY DO SOMETHING
  447. *            DIFFERENT FOR 6/12 AND DISPLAY CODE SEND.  ADD 'SET
  448. *            TEXT-MODE XXXX' COMMAND TO FORCE PROPER CONVERSIONS FOR
  449. *            TEXT FILE SEND AND RECEIVE.
  450. *
  451. *     3.1 12/18/84  PAUL WELLS, UNIVERSITY OF WASHINGTON.
  452. *        MINOR CHANGES.  PUT RDELAY CODE BACK IN TO TAKE ADVANTAGE OF
  453. *        IAF TYPEAHEAD MODIFICATION.
  454. *
  455. *     3.0 10/15/84  JOERG HALLBAUER CAL STATE UNIVERSITIES
  456. *        MANY CHANGES FOR NOS 2.2.  SOME OF THE MAJOR ONES INCLUDE: 
  457. *
  458. *        1. REMOVED CONDITIONAL CODE SUPPORTING THE UT2D AND NOS/BE
  459. *        OPERATING SYSTEMS (SORRY GUYS, BUT IT WAS JUST TOO HARD TO
  460. *        READ/MAINTAIN THE CODE, AND I HAVE NO WAY OF TESTING MY
  461. *        MODS TO BE SURE THAT I DIDNT BREAK IT FOR THOSE SYSTEMS).
  462. *
  463. *        2. USED OVERLAYS TO REDUCE FIELD LENGTH AND STILL ALLOW THE
  464. *        PROGRAM TO BE INSTALLED ON THE SYSTEM.
  465. *
  466. *        3. ADDED SUPPORT FOR 8/12 DISK FILES AND AUTO CHARACTER
  467. *        SET RECOGNITION.  KERMIT FILE MODES ARE NOW "TEXT" OR
  468. *        "BINARY".
  469. *
  470. *        4. CHANGED NEL CHARACTER TO 3777B TO AVOID CONFUSION WITH
  471. *        EIGHT BIT DATA.
  472. *
  473. *        5. CHANGED CYBER BINARY FILE FORMAT TO PACKED 7.5 BYTES/WORD
  474. *        (60 BIT BINARY) TO ALLOW CYBER BINARY FILES TO BE SENT TO
  475. *        A MICRO, AND TO MAINTAIN COMPATABILITY WITH THE CYBER RMF
  476. *        AND XMODEM UTILITIES.
  477. *
  478. *        6. ADDED #EOR AND #EOF TO PRESERVE THE STRUCTURE OF CYBER
  479. *        TEXT FILES (E.G. CCL PROCFILES).
  480. *
  481. *        7. USED MULTIMESSAGE TRANSPARENT INPUT TO ALLOW RECEPTION
  482. *        OF BINARY FILES WITHOUT EIGHT-BIT QUOTING (ASSUMING THAT
  483. *        THE COMMUNICATION PATH IS EIGHT BITS WIDE).  EIGHT BIT QUOTING
  484. *        IS STILL SUPPORTED IF NEEDED.
  485. *
  486. *        8. REMOVED THE PARITY SETTING CODE IN *PUTC*.  ON A CYBER
  487. *        UNDER NOS, PARITY IS >NOT< THE RESPONSIBILITY OF AN APPLICATION
  488. *        PROGRAM - IT IS SET BY THE OPERATING SYSTEM (I.E. CCP).  IF
  489. *        IT IS INCORRECT THERE, CHANCES ARE YOU WILL NEVER GET FAR
  490. *        ENOUGH TO START THIS PROGRAM.  IF IT IS SET CORRECTLY, THEN
  491. *        THE PROGRAM DOESN*T NEED TO DO IT.  IN ANY CASE, IF THE PARITY
  492. *        IN THE OPERATING SYSTEM IS SET TO ANYTHING OTHER THAN *NONE*,
  493. *        SETTING THE HIGH BIT WHEN WE SEND CHARACTERS IS FUTILE.
  494. *
  495. *        9. ADDED DATA COMPRESSION/REPEAT COUNTS.
  496. *
  497. *        10. FIXED THE ! (MONITOR COMMAND) COMMAND.
  498. *
  499. *        11. KERMIT WILL NOW ATTEMPT TO GET OR ATTACH A FILE TO
  500. *        BE SENT IF IT IS NOT LOCAL.
  501. *
  502. *        12. IMPLEMENTED SERVER *LOGOUT* COMMAND.  IT NOW WILL LOG
  503. *        YOU OUT - SO BE SURE YOU DON*T HAVE ANY LOCAL FILES YOU
  504. *        WANT TO KEEP.  THE SERVER *FINISH* COMMAND WILL STOP THE
  505. *        SERVER WITHOUT LOGGING YOU OUT.
  506. *
  507. *        13. ALL IMPLEMENTED SERVER COMMANDS (SEND, GET, FINISH,
  508. *        AND LOGOUT) WORK AS ADVERTISED.
  509. *
  510. *
  511. *
  512. *     X.X 8/17/84   OLAF PORS, UNIVERSITY OF VIRGINIA
  513. *        KERMIT WAS ADAPTED TO NOS 2.1 (LEVEL 580 AND HOPEFULLY
  514. *        LATER RELEASES).  DISK FILE FORMATS ARE "ASCII" - 6/12
  515. *        DISPLAY CODE (74B AND 76B ESCAPE SEQUENCES), AND
  516. *        "BINARY" - 8-BIT BINARY CHARACTERS IN 12-BIT
  517. *        BYTES.  6/12 ASCII HAS UP TO 66-BIT
  518. *        ZERO LINE TERMINATORS.  8/12 BINARY USES ZERO BYTES
  519. *        AS FILLER (IGNORED), AND 4000B AS A ZERO. INPUT TO
  520. *        THE PROGRAM FROM THE TERMINAL IS DONE IN ASCII MODE,
  521. *        I.E., 6/12 ASCII.  THE MODE THAT THE TERMINAL WAS IN
  522. *        BEFORE KERMIT WAS EXECUTED IS RESTORED ON EXIT,
  523. *        UNLESS THE USER TERMINATES KERMIT WITH THE TERMINAL
  524. *        BREAK 2 SEQUENCE.  JUST BEFORE FILE TRANSMISSION
  525. *        TAKES PLACE, CCP IS TOLD TO TURN ECHOPLEX OFF, SO THAT
  526. *        THE KERMIT ON THE OTHER END WON'T INTERPRET AN
  527. *        ECHOED CARRIAGE RETURN AS A ZERO-LENGTH PACKET
  528. *        FROM THE CYBER.  AT THE END OF FILE TRANSMISSION,
  529. *        ECHOPLEX IS RESTORED TO WHATEVER 'DUPLEX' IS SET TO.
  530. *        OUTPUT TO THE TERMINAL IS DONE USING TRANSPARENT
  531. *        OUTPUT (0007 CONTROL BYTE).
  532. *        IN ORDER TO TRANSFER BINARY FILES ACROSS LOCAL AREA
  533. *        NETWORKS WHICH MAY NOT PRESERVE PARITY BITS,
  534. *        8-BIT QUOTING IS ACCEPTED ON FILE RECEPTION, AND
  535. *        REQUESTED DURING FILE SENDING.
  536. *        NO EFFORT WAS MADE TO GET THE SERVER FUNCTION TO
  537. *        WORK SINCE FEW OF THE KERMITS ON THE OTHER END
  538. *        WOULD BE ABLE TO SEND SERVER COMMAND PACKETS.
  539. *        IN FACT, THE ONLY COMMANDS SUPPORTED/ADVERTISED
  540. *        TO USERS AT UVA ARE "SET FILE-MODE", "SHOW",
  541. *        "SEND" AND "RECEIVE".  THESE ARE ALL THE COMMANDS
  542. *        NEEDED TO ACCOMPLISH FILE TRANSFERS.
  543. *
  544. *     2.0   4/17/84  JIM KNUTSON, UNIVERSITY OF TEXAS AT AUSTIN
  545. *        FIX FILENAME PACKET TO SEND UPPERCASE FILE NAMES ONLY.
  546. *        CLEANUP ERROR PACKET HANDLING (ADDED TO STATE TABLE HANDLERS).
  547. *        FIX RETRY COUNTS TO USE PROPER NUMBER. MODIFY CHARACTER TABLES.
  548. *        MERGE RIC ANDERSON'S NOS/BE CODE.  TRY TO ORGANIZE THE
  549. *        SOURCE A LITTLE BETTER.  ADDED PUSH AND ! COMMANDS.
  550. *        ADD READ DELAY FOR PERFORMANCE TUNING.  CHANGED NEL BACK TO
  551. *        205B.  THE BINARY DATA-MODE IGNORES NEL THOUGH.
  552. *        UT2D REQUIRES THE NEL BE A 205B.  CHANGED CHARACTER TABLES
  553. *        TO USE OCTAL CONSTANTS FOR NON-REPRESENTABLE CHARACTERS.
  554. *
  555. *     1.1   01/21/84  RIC ANDERSON, UNIVERSITY OF ARIZONA AT TUSCON
  556. *        ADD OVCAPS FOR INSTALLATION IN NUCLEUS.  ADD DISPLAY CODE
  557. *        SUPPORT.  REMOVE GOBS AND GOBS OF FIELD LENGTH.  CHANGED
  558. *        NEL TO 4012B TO AVOID CONFUSION WITH DATA BYTE.  UPDATED
  559. *        CHARACTER TABLES FOR 63 AND 64 CHARACTER SETS.  CHANGED
  560. *        PERCENTS IN FPRINTFS TO AT-SIGNS SINCE 63 CHARACTER SET HAS
  561. *        NO PERCENT SIGN.
  562. *
  563. *     1.0   10/14/84  JIM KNUTSON, UNIVERSITY OF TEXAS AT AUSTIN
  564. *        ORIGINAL IMPLEMENTATION.
  565. *
  566. *     JIM KNUTSON
  567. *     COMPUTATION CENTER ROOM 1
  568. *     UNIVERISITY OF TEXAS
  569. *     AUSTIN, TX   78712
  570. *
  571. *     APRPANET ADDRESS:  KNUTSON@UT-NGP
  572. *
  573. *     SPECIAL THANKS TO KING ABLES FOR HIS CONTRIBUTION.
  574. *
  575. *     MODIFIED FOR NOS/BE BY RIC ANDERSON
  576. *     UNIVERSITY OF ARIZONA
  577. *     COMPUTER CENTER
  578. *     TUCSON, ARIZONA 85721
  579. *
  580. *     MODIFIED FOR NOS 2.2 BY JOERG HALLBAUER
  581. *     CALIFORNIA STATE UNIVERSITIES
  582. *     STATE UNIVERSITIY DATA CENTER
  583. *     5670 WILSHIRE BLV. SUITE 2600
  584. *     LOS ANGELES CA.  90036
  585. *
  586. *     FUTURE ENHANCEMENTS: 
  587. *        MOVE HELP TEXT TO INDEXED RANDOM FILE
  588. *        WILD CARD SENDS
  589. *
  590. *
  591. *     BUILD SEQUENCE: 
  592. *
  593. *        FTN5,I,OPT=2,S=NOSTEXT,S=PSSTEXT,B=B1,CS.
  594. *        FTN5,I,OPT=2,S=NOSTEXT,S=PSSTEXT,B=B2,CS.
  595. *        LIBGEN(F=B2,P=KERMLIB)
  596. *        LDSET,LIB=KERMLIB/SRVLIB.
  597. *        LOAD,B1.
  598. *        NOGO,KERMIT.
  599. *
  600. *
  601. *     KERMIT I/O CONSIDERATIONS: 
  602. *
  603. *        KERMIT USES TWO MODES OF TERMINAL INPUT.  WHEN READING COMMANDS
  604. *        AND SENDING FILES (FROM COMMAND RATHER THAN SERVER MODE) IT
  605. *        USES NORMAL CODED (6/12) INPUT.  WHEN RECEIVING FILES, AND IN
  606. *        SERVER MODE, IT USES MULTIMESSAGE TRANSPARENT INPUT IN ORDER
  607. *        TO PROVIDE AN EIGHT BIT DATA PATH.
  608. *
  609. *        TERMINAL OUTPUT IS ALWAYS DONE IN TRANSPARENT MODE.
  610. *
  611. *        DISK I/O MAY BE IN ANY OF FOUR CHARACTER SETS: 
  612. *           1. DISPLAY CODE - 6 BITS/CHARACTER.
  613. *           2. EXTENDED DISPLAY CODE (6/12) - 6 OR 12 BITS/CHARACTER.
  614. *           3. 8/12 ASCII - 8 BITS/CHARACTER IN 12 BIT BYTES.
  615. *           4. BINARY - 60 BITS/WORD (7.5 BYTES/WORD).
  616. *
  617. *        TO SUPPORT CDC*S UNIQUE (READ STRANGE) SYSTEM OF FILE AND
  618. *        RECORD MARKS KERMIT WILL CONVERT EOR*S IN A CYBER TEXT FILE
  619. *        TO A LINE CONTAINING #EOR ON THE MICRO.  LIKEWISE EOF*S ARE
  620. *        CONVERTED TO #EOF.  THUS MULTI-FILE AND MULTI-RECORD TEXT
  621. *        FILES MAY BE STORED (OR CREATED) ON A MICRO AND THEN SENT
  622. *        BACK TO A CYBER WITH THEIR STRUCTURE INTACT.
  623. *
  624. *        THIS CONVENTION IS THE SAME ONE USED BY CDC*S RMF (REMOTE
  625. *        MICRO FACILITY) PRODUCT.
  626. *
  627. *        BINARY FILES WILL NOT HAVE THEIR RECORD STRUCTURE PRESERVED,
  628. *        SO THE ONLY CYBER BINARIES THAT CAN BE SUCCESSFULLY MOVED TO
  629. *        A MICRO AND THEN RESTORED TO THE CYBER ARE THOSE THAT CONSIST
  630. *        OF A SINGLE RECORD (E.G. DATA FILES AND NON-OVERLAYED ABSOLUTE
  631. *        EXECUTABLE PROGRAMS).
  632.  
  633.  
  634.       IMPLICIT INTEGER (A-Z)
  635.       PARAMETER (COMLIS = 0)
  636.  
  637. *CALL COMCKER
  638.  
  639.       EXTERNAL EXITPGM
  640.  
  641.  
  642. *     INITIALIZE
  643.  
  644. *IF -DEF,DEBUG,1
  645.       CALL OVERLAY('KRM0100',1,0,'RECALL',1)
  646.       IF(CMDFD .LT. 0) CALL OVERLAY('KRM1300', O"13",0,'RECALL',1)
  647. *IF DEF,DEBUG,1
  648.       CALL OVERLAY('KERMIT',1,0,'RECALL')
  649.  
  650. *     TRAP USER BREAKS AND TIME LIMITS
  651.  
  652.       CALL RECOVR(EXITPGM,O"204",0)
  653.  
  654. *     READ AND PARSE USER COMMANDS
  655.  
  656.  5    CALL GETCMD
  657.       GO TO (200, 10, 20, 30, 10, 40, 50, 60, 70, 80, 90, 100, 110),
  658.      +  CINDEX
  659.  
  660. *     - D I R E C T O R Y -
  661.  
  662.  200  CALL OVERLAY('KRM1200',O"12",0,'RECALL',1)
  663.       GO TO 5
  664.  
  665.  
  666. *     - E X I T -
  667. *     - Q U I T -
  668.  
  669.  10   CALL EXITPGM
  670.  
  671. *     - H E L P -
  672.  
  673. *IF -DEF,DEBUG,1
  674.  20   CALL OVERLAY('KRM0300',3,0,'RECALL',1)
  675. *IF DEF,DEBUG,1
  676.  20   CALL OVERLAY('KERMIT',3,0,'RECALL')
  677.       GO TO 5
  678.  
  679. *     - P U S H -
  680.  
  681.  30   AUTORET = NO
  682. *IF -DEF,DEBUG,1
  683.       CALL OVERLAY('KRM0200',2,0,'RECALL',1)
  684. *IF DEF,DEBUG,1
  685.       CALL OVERLAY('KERMIT',2,0,'RECALL')
  686.       GO TO 5
  687.  
  688. *     - R E C E I V E -
  689.  
  690. *IF -DEF,DEBUG,1
  691.  40   CALL OVERLAY('KRM0400',4,0,'RECALL',1)
  692. *IF DEF,DEBUG,1
  693.  40   CALL OVERLAY('KERMIT',4,0,'RECALL')
  694.       GO TO 5
  695.  
  696. *     - S E N D -
  697.  
  698. *IF -DEF,DEBUG,1
  699.  50   CALL OVERLAY('KRM0500',5,0,'RECALL',1)
  700. *IF DEF,DEBUG,1
  701.  50   CALL OVERLAY('KERMIT',5,0,'RECALL')
  702.       GO TO 5
  703.  
  704. *     - S E R V E R -
  705.  
  706. *IF -DEF,DEBUG,1
  707.  60   CALL OVERLAY('KRM1100',O"11",0,'RECALL',1)
  708. *IF DEF,DEBUG,1
  709.  60   CALL OVERLAY('KERMIT',O"11",0,'RECALL')
  710.       GO TO 5
  711.  
  712. *     - S E T -
  713.  
  714. *IF -DEF,DEBUG,1
  715.  70   CALL OVERLAY('KRM0600',6,0,'RECALL',1)
  716. *IF DEF,DEBUG,1
  717.  70   CALL OVERLAY('KERMIT',6,0,'RECALL')
  718.       GO TO 5
  719.  
  720. *     - S H O W -
  721.  
  722. *IF -DEF,DEBUG,1
  723.  80   CALL OVERLAY('KRM0700',7,0,'RECALL',1)
  724. *IF DEF,DEBUG,1
  725.  80   CALL OVERLAY('KERMIT',7,0,'RECALL')
  726.       GO TO 5
  727.  
  728. *     - S T A T U S -
  729.  
  730. *IF -DEF,DEBUG,1
  731.  90   CALL OVERLAY('KRM1000',O"10",0,'RECALL',1)
  732. *IF DEF,DEBUG,1
  733.  90   CALL OVERLAY('KERMIT',O"10",0,'RECALL')
  734.       GO TO 5
  735.  
  736. *     - T A K E -
  737.  
  738. 100   CALL OVERLAY('KRM1300', O"13",0,'RECALL',1)
  739.       GOTO 5
  740.  
  741. *     - ! -
  742.  
  743.  110  AUTORET = YES
  744. *IF -DEF,DEBUG,1
  745.       CALL OVERLAY('KRM0200',2,0,'RECALL',1)
  746. *IF DEF,DEBUG,1
  747.       CALL OVERLAY('KERMIT',2,0,'RECALL')
  748.       GO TO 5
  749.  
  750.  
  751.       END
  752.       BLOCK DATA
  753.  
  754. ***   BLOCK DATA - INITIALIZE VARIABLES IN COMMON.
  755. *
  756.  
  757.       IMPLICIT INTEGER (A-Z)
  758.       PARAMETER (COMLIS = 1)
  759.  
  760. *CALL COMCKER
  761.  
  762.       DATA CMDFD            / STDIN          /
  763.       DATA DEBUG  , DEBUGFD / DBGOFF, 0      /
  764.       DATA DUPLEX           / FULLDUP        /
  765.       DATA FFD              / 0              /
  766.       DATA FILMODE          / TEXT           /
  767.       DATA TXTMODE          / CSNONE         /
  768.       DATA FMODE            / MAXFILE*CLOSED /
  769.       DATA FNWDS            / MAXFILE*0      /
  770.       DATA FUNGTCH          / MAXFILE*EOF    /
  771.       DATA FWPTR            / MAXFILE*0      /
  772.       DATA INITDUP          / FULLDUP        /
  773.       DATA MAXRINI          / MAXINIT        /
  774.       DATA MAXRTRY          / MAXTRY         /
  775.       DATA PACKNUM          / 0              /
  776.       DATA RDELAY           / 0              /
  777.       DATA SCHCNT , RCHCNT  / 2*0            /
  778.       DATA SCHOVRH, RCHOVRH / 2*0            /
  779.       DATA STARTIM, ENDTIM  / 2*0            /
  780.       DATA STATE            / C              /
  781.       DATA WAITPAK          / .TRUE.         /
  782.  
  783.       DATA SSYNC  , DSYNC  , RSYNC   / 3*SOH           /
  784.       DATA SPKSIZE, DPKSIZE, RPKSIZE / IPKSIZE, 2*LPKSIZE /
  785.       DATA STIMOUT, DTIMOUT, RTIMOUT / 3*ITIMOUT       /
  786.       DATA SPADCT , DPADCT , RPADCT  / 3*IPADCT        /
  787.       DATA SPADCH , DPADCH , RPADCH  / 3*IPADCH        /
  788.       DATA SEOLCH , DEOLCH , REOLCH  / 3*IEOLCH        /
  789.       DATA SCQUOTE, DCQUOTE, RCQUOTE / 3*ICQUOTE       /
  790.       DATA S8QUOTE, D8QUOTE, R8QUOTE / Y,N,N           /
  791.       DATA SCHKTYP, DCHKTYP, RCHKTYP / 3*ICHKTYP       /
  792.       DATA SRPTPFX, DRPTPFX, RRPTPFX / IRPTPFX,2*BLANK /
  793.  
  794. *     IT IS UGLY TO MAKE THE SUCCESSFUL INITIATION OF FILE
  795. *     TRANSMISSION DEPENDENT ON THE TIMING OF A USER TYPEIN.
  796. *     HOWEVER, SUPPOSE WE TRANSMIT OUR SEND-INIT IMMEDIATELY.
  797. *     THE OTHER KERMIT WON'T BE PREPARED TO RECEIVE IT
  798. *     SINCE THE USER NEEDS TO ENTER SOME COMMANDS TO GET THE
  799. *     OTHER KERMIT GOING, SO THE USER CAN SIMPLY FINISH
  800. *     HIS TYPEINS AT HIS LEISURE, ENDING WITH 'RECEIVE',
  801. *     THEN HIT ANOTHER CARRIAGE RETURN TO CAUSE US TO
  802. *     RETRANSMIT THE SEND-INIT.  THUS, HE NEED FEEL NO
  803. *     TIME PRESSURE.  WITH DELAYFP SET TO ZERO (NO DELAY),
  804. *     THE FIRST SEND-INIT APPEARS AS GARBAGE ON HIS
  805. *     SCREEN.  DELAYFP IS SET TO 2 SECONDS, TO GIVE THE
  806. *     USER A LITTLE TIME TO GET OUT OF 'CONNECT' MODE,
  807. *     SO HE WON'T SEE THE TRASH, BUT 2 SECONDS IS NOT SO
  808. *     LONG THAT HE HAS TO WAIT IMPATIENTLY FOR THE
  809. *     TRANSFER TO START.  2 SECONDS SHOULD ALSO BE SHORT
  810. *     ENOUGH SO THAT HE DOESN'T HAVE TIME ENOUGH TO
  811. *     TYPE 'RECEIVE', SO THAT HE MAY EXPECT CONSISTENTLY
  812. *     TO INITIATE THE TRANSFER WITH A FINAL CARRIAGE RETURN.
  813.  
  814.       DATA DELAYFP          / 2 /
  815.  
  816.       DATA DEBUGFN          / 75, 69, 82, 77, 76, 79, 71, 0 /
  817. *                              K   E   R   M   L   O   G
  818.  
  819.       DATA (ERRMSG(I),I=1,14) / 63, 75, 101, 114, 109, 105, 116, 45, 49,
  820. *                             ?   K    E    R    M    I    T   -   1
  821.      +                       55, 48, 58, 2*32 /
  822. *                             7   0   : 
  823.       DATA (MICMSG(I),I=1, 15) / 40, 76, 111, 99, 97, 108, 32, 75, 101,
  824. *                                 (   L    O   C   A    L       K    E
  825.      +   114, 109, 105, 116, 41, 32/
  826. *          R    M    I    T   )
  827.  
  828.       DATA ABORTYP / 0 /
  829.  
  830.       DATA VERSION / '^CYBER-170/^N^O^S ^K^E^R^M^I^T ^VER 3.3    @S\N' /
  831.       DATA HLPASCH / '^DECIMAL, OCTAL (^B), OR HEXIDECIMAL (^H) CODE FOR
  832.      + ^A^S^C^I^I CHARACTER \N' /
  833.       DATA HLPDLFP / '^NUMBER OF SECONDS TO DELAY FIRST PACKET\N' /
  834.       DATA HLPDBFN / '^DEBUG OUTPUT LOGFILE SPECIFICATION\N' /
  835.       DATA HLPPLEN / '^MAXIMUM PACKET LENGTH\N' /
  836.       DATA HLPPADL / '^NUMBER OF PAD CHARACTERS TO USE\N' /
  837.       DATA HLPIPRC / '^INITIAL PACKET RETRY COUNT\N' /
  838.       DATA HLPPRTR / '^PACKET RETRY COUNT\N' /
  839.       DATA HLPTIMO / '^NUMBER OF SECONDS TO WAIT BEFORE TIMEOUT\N' /
  840.       DATA HLPSNFN / '^FILE ^NAME\N' /
  841.       DATA HLPRDEL / '^MILLISECONDS TO DELAY EACH ^T^T^Y READ\N' /
  842.  
  843.       DATA DPCTBL/R" ",31*R" ",R" ",R"!",R"""",O"60",R"$",O"63",R"&",
  844. * 63  DATA DPCTBL/R" ",31*R" ",R" ",R"!",R"""",O"60",R"$",R" ",R"&",
  845.      +            O"70",R"(",R")",R"*",R"+",R",",R"-",R".",R"/",R"0",
  846.      +            R"1",R"2",R"3",R"4",R"5",R"6",R"7",R"8",R"9",O"0",
  847. * 63 +            R"1",R"2",R"3",R"4",R"5",R"6",R"7",R"8",R"9",O"63",
  848.      +            R";",R"<",R"=",R">",O"71",R"@",R"A",R"B",R"C",R"D",
  849.      +            R"E",R"F",R"G",R"H",R"I",R"J",R"K",R"L",R"M",R"N",
  850.      +            R"O",R"P",R"Q",R"R",R"S",R"T",R"U",R"V",R"W",R"X",
  851.      +            R"Y",R"Z",R"[",O"75",R"]",O"76",O"65",R"@",R"A",
  852.      +            R"B",R"C",R"D",R"E",R"F",R"G",R"H",R"I",R"J",R"K",
  853.      +            R"L",R"M",R"N",R"O",R"P",R"Q",R"R",R"S",R"T",R"U",
  854.      +            R"V",R"W",R"X",R"Y",R"Z",R"[",R"\",R"]",R"^",R" "/
  855.  
  856.         DATA LASCII/58,97,98,99,100,101,102,103,104,105,106,107,108,109,
  857. *                    :  A  B  C   D   E   F   G   H   I   J   K   L   M
  858. * 63    DATA LASCII/32,97,98,99,100,101,102,103,104,105,106,107,108,109,
  859. * 63                    A  B  C   D   E   F   G   H   I   J   K   L   M
  860.      +              110,111,112,113,114,115,116,117,118,119,120,121,122,
  861. *                     N   O   P   Q   R   S   T   U   V   W   X   Y   Z
  862.      +              48,49,50,51,52,53,54,55,56,57,
  863. *                    0  1  2  3  4  5  6  7  8  9
  864.      +              43,45,42,47,40,41,36,61,32,44,46,35,91,93,37,
  865. *                    +  -  *  /  (  )  $  =     ,  .  <  [  ]  <PCT>
  866. * 63 +              43,45,42,47,40,41,36,61,32,44,46,35,91,93,58,
  867. * 63                 +  -  *  /  (  )  $  =     ,  .  <  [  ]  : 
  868.      +              34,95,33,38,39,63,60,62,64,92,94,59/
  869. *                    "  #  !  &  '  ?  <  >  @  \  ^  ;
  870.  
  871.         DATA UASCII/58,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
  872. *                    :  A  B  C  D  E  F  G  H  I  J  K  L  M  N  O  P
  873. * 63    DATA UASCII/32,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
  874. * 63                    A  B  C  D  E  F  G  H  I  J  K  L  M  N  O  P
  875.      +              81,82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54,
  876. *                    Q  R  S  T  U  V  W  X  Y  Z  0  1  2  3  4  5  6
  877.      +              55,56,57,43,45,42,47,40,41,36,61,32,44,46,35,91,93,
  878. *                    7  8  9  +  -  *  /  (  )  $  =     ,  .  <  [  ]
  879.      +              37,34,95,33,38,39,63,60,62,64,92,94,59/
  880. *                <PCT>  "  #  !  &  '  ?  <  >  @  \  ^  ;
  881. * 63 +              58,34,95,33,38,39,63,60,62,64,92,94,59/
  882. * 63                 :  "  #  !  &  '  ?  <  >  @  \  ^  ;
  883.  
  884.  
  885.       DATA SX1274 /
  886.      +  BLANK,O"100",O"136",BLANK,O"72",BLANK,BLANK,O"140",56*BLANK/
  887. * 63 +  BLANK,O"100",O"136",BLANK,O"45",BLANK,BLANK,O"140",56*BLANK/
  888.  
  889.       DATA  SX1276 /
  890.      +  BLANK,O"141",O"142",O"143",O"144",O"145",O"146",O"147",O"150",
  891.      +  O"151",O"152",O"153",O"154",O"155",O"156",O"157",O"160",O"161",
  892.      +  O"162",O"163",O"164",O"165",O"166",O"167",O"170",O"171",O"172",
  893.      +  O"173",O"174",O"175",O"176",O"177",O"4000",O"1",O"2",O"3",O"4",
  894.      +  O"5",O"6",O"7",O"10",O"11",O"12",O"13",O"14",O"15",O"16",
  895.      +  O"17",O"20",O"21",O"22",O"23",O"24",O"25",O"26",O"27",O"30",
  896.      +  O"31",O"32",O"33",O"34",O"35",O"36",O"37"/
  897.  
  898.       DATA  ASC612 /
  899.      +  O"7640",O"7641",O"7642",O"7643",O"7644",O"7645",O"7646",O"7647",
  900.      +  O"7650",O"7651",O"7652",O"7653",O"7654",O"7655",O"7656",O"7657",
  901.      +  O"7660",O"7661",O"7662",O"7663",O"7664",O"7665",O"7666",O"7667",
  902.      +  O"7670",O"7671",O"7672",O"7673",O"7674",O"7675",O"7676",O"7677",
  903.      +  O"55",O"66",O"64",O"60",O"53",O"63",O"67",O"70",O"51",O"52",
  904. * 63 +  O"55",O"66",O"64",O"60",O"53",O"7404",O"67",O"70",O"51",O"52",
  905.      +  O"47",O"45",O"56",O"46",O"57",O"50",O"33",O"34",O"35",O"36",
  906.      +  O"37",O"40",O"41",O"42",O"43",O"44",O"7404",O"77",O"72",O"54",
  907. * 63 +  O"37",O"40",O"41",O"42",O"43",O"44",O"63",O"77",O"72",O"54",
  908.      +  O"73",O"71",O"7401",O"1",O"2",O"3",O"4",O"5",O"6",O"7",O"10",
  909.      +  O"11",O"12",O"13",O"14",O"15",O"16",O"17",O"20",O"21",O"22",
  910.      +  O"23",O"24",O"25",O"26",O"27",O"30",O"31",O"32",O"61",O"75",
  911.      +  O"62",O"7402",O"65",O"7407",O"7601",O"7602",O"7603",O"7604",
  912.      +  O"7605",O"7606",O"7607",O"7610",O"7611",O"7612",O"7613",O"7614",
  913.      +  O"7615",O"7616",O"7617",O"7620",O"7621",O"7622",O"7623",O"7624",
  914.      +  O"7625",O"7626",O"7627",O"7630",O"7631",O"7632",O"7633",O"7634",
  915.      +  O"7635",O"7636",O"7637"/
  916.  
  917.  
  918.       END
  919.       SUBROUTINE GETCMD
  920.  
  921. ***   GETCMD - READ AND PARSE A COMMAND
  922. *
  923. *     PROMPT THE USER FOR A COMMAND AND RETURN AN INTEGER
  924. *     INDEX CORRESPONDING TO THE COMMAND.
  925.  
  926.       IMPLICIT INTEGER (A-Z)
  927.       PARAMETER (COMLIS = 0)
  928.  
  929. *CALL COMCKER
  930.  
  931.       PARAMETER (TSIZE = 13)
  932.       CHARACTER*10 CMD(TSIZE)
  933.  
  934.       DATA CMD / 'DIRECTORY', 'EXIT', 'HELP', 'PUSH', 'QUIT', 'RECEIVE',
  935.      +  'SEND', 'SERVER', 'SET', 'SHOW', 'STATUS', 'TAKE', '!' /
  936.  
  937.  
  938. 10    CONTINUE
  939.       IF(CMDFD .EQ. STDIN) THEN
  940.          CALL FPRINTF(STDOUT,'^KERMIT-170>')
  941.          CALL FFLUSH(STDOUT)
  942.          CALL FFLUSH(STDIN)
  943.       ENDIF
  944.       CINDEX = MATCH(CMD,TSIZE,.TRUE.)
  945.       IF (CINDEX .EQ. EOF) THEN
  946.          IF(CMDFD .NE. STDIN) THEN
  947.             CALL FCLOSE(CMDFD)
  948.             IF(.NOT.CMDLOCF) CALL RETFILE(CMDLFN)
  949.          ENDIF
  950.          CMDFD = STDIN
  951.          GOTO 10
  952.       ELSE IF (CINDEX .EQ. ERROR .OR. CINDEX .EQ. 0) THEN
  953.          GOTO 10
  954.       ENDIF
  955.  
  956.       RETURN
  957.       END
  958.       SUBROUTINE EXITPGM
  959.  
  960. ***   EXITPGM - EXIT THE PROGRAM
  961. *
  962.  
  963.       IMPLICIT INTEGER (A-Z)
  964.       PARAMETER (COMLIS = 0)
  965.  
  966. *CALL COMCKER
  967.  
  968.  
  969. *     RESET TERMINAL PARAMETERS IN CASE OF ABORT
  970.  
  971.       IF (INITDUP .EQ. FULLDUP) THEN
  972.          CALL STTY('RCV-OFF',FULLDUP)
  973.       ELSE
  974.          CALL STTY('RCV-OFF',HALFDUP)
  975.       ENDIF
  976.  
  977. *     FLUSH THE DEBUG FILE
  978.  
  979.       IF (DEBUGFD .NE. CLOSED) CALL FCLOSE(DEBUGFD)
  980.  
  981. *     EXIT TO OPERATING SYSTEM
  982.  
  983.       CALL ENDRUN
  984.  
  985.       END
  986.       OVERLAY(1,0)
  987.       PROGRAM KRM0100
  988.  
  989. ***   PRESET - INITIALIZE RUNNING ENVIRONMENT.
  990. *
  991.  
  992.       IMPLICIT INTEGER (A-Z)
  993.       PARAMETER (COMLIS = 0)
  994.  
  995. *CALL COMCKER
  996.  
  997.       CHARACTER*10 FN
  998.       LOGICAL CFE
  999.       DIMENSION  FET(6), BUFFER(1000)
  1000.  
  1001.       DATA FN / ' ' /
  1002.  
  1003. *     INSURE WE ARE AN INTERACTIVE JOB.
  1004.  
  1005.       IF (USTART().NE.0) THEN
  1006.          CALL REMARK(' KERMIT - INCORRECT JOB ORIGIN.')
  1007.          CALL ABORT
  1008.       ENDIF
  1009.  
  1010. *     KERMIT IS WRITTEN TO USE THE DISPLAY CODE COLLATING
  1011. *     SEQUENCE WITH THE CHAR AND ICHAR FUNCTIONS.
  1012.  
  1013.       CALL COLSEQ('DISPLAY')
  1014.  
  1015. *     IF 63 CHARACTER SET, FIX THE CONVERSION TABLES.
  1016.  
  1017.       IF(ICHAR(':') .EQ. O"63") CALL FIXCTAB
  1018.  
  1019. *     OPEN THE I/O FILES.
  1020.  
  1021.       IF (FOPEN('STDIN',RD,CS612) .NE. STDIN) THEN
  1022.          CALL REMARK(' CANNOT OPEN STANDARD INPUT')
  1023.          CALL ABORT
  1024.       ELSE IF (FOPEN('STDOUT',WR,CSTXP) .NE. STDOUT) THEN
  1025.          CALL REMARK(' CANNOT OPEN STANDARD OUTPUT')
  1026.          CALL ABORT
  1027.       ENDIF
  1028.  
  1029. *     READ IN ENVIRONMENT IF PRESENT
  1030.  
  1031.       IF (CFE('ZZZZKEN')) THEN
  1032.          CALL MAKEFET('ZZZZKEN', FET, 6, BUFFER, 1000)
  1033.          CALL REWIND(FET, 1)
  1034.          CALL READ(FET, 1)
  1035.          CALL READW(FET,HEADER,LOCF(TRAILER)-LOCF(HEADER),STATUS)
  1036.          CALL RETURN(FET, 1)
  1037.       ELSE
  1038.          CALL DPC2AS(VERSDAT, VERSSTR, 10)
  1039.          CALL FPRINTF(STDOUT,VERSION,VERSSTR,0,0,0)
  1040.          CMDFD = -1
  1041.       ENDIF
  1042.  
  1043.  
  1044.       RETURN
  1045.       END
  1046.       SUBROUTINE FIXCTAB
  1047.  
  1048. ***   FIXCTAB - FIX CONVERSION TABLES IF RUNNING ON A 63 CHARACTER SET
  1049. *     NOS SYSTEM.  WE NEED TO REVERSE THE COLON AND PERCENT SIGN FOR
  1050. *     ASCII CHARACTER SETS, AND REMOVE THE PERCENT SIGN IN DISPLAY CODE.
  1051. *
  1052.  
  1053.       IMPLICIT INTEGER (A-Z)
  1054.       PARAMETER (COMLIS = 0)
  1055.  
  1056. *CALL COMCKER
  1057.  
  1058.  
  1059.  
  1060.       DPCTBL(37) = R" "
  1061.       DPCTBL(58) = O"63"
  1062.       LASCII(0) = 32
  1063.       LASCII(O"63") = 58
  1064.       UASCII(0) = 32
  1065.       UASCII(O"63") = 58
  1066.       SX1274(4) = O"45"
  1067.       ASC612(37) = O"7404"
  1068.       ASC612(58) = O"63"
  1069.  
  1070.       RETURN
  1071.       END
  1072.       OVERLAY(2,0)
  1073.       PROGRAM KRM0200
  1074.  
  1075. ***   EXECMD - EXECUTE A CONTROL STATEMENT
  1076. *
  1077. *     EXECUTE A CONTROL STATEMENT AND RETURN TO COMMAND MODE OR
  1078. *     EXIT TO THE OPERATING SYSTEM.  NEXT EXECUTION OF KERMIT
  1079. *     WILL START WITH THE CURRENT ENVIRONMENT.  THIS SUBROUTINE
  1080. *     DOES NOT RETURN UNLESS THERE ARE ERRORS.
  1081. *
  1082. *     WE WRITE OUT THE KERMIT ENVIRONMENT USING THE NOS *SRVLIB*
  1083. *     ROUTINES BECAUSE WE WRITE OUT THE KERMIT FILE/BUFFER AREAS.
  1084. *
  1085.  
  1086.       IMPLICIT INTEGER (A-Z)
  1087.       PARAMETER (COMLIS = 0)
  1088.  
  1089. *CALL COMCKER
  1090.  
  1091.       BOOLEAN STR(80)
  1092.       CHARACTER*80 CMD
  1093.       LOGICAL CONFIRM
  1094.       DIMENSION FET(6), BUFFER(1000)
  1095.  
  1096. *     BEFORE WE DO ANYTHING RASH
  1097.  
  1098.       IF (AUTORET .EQ. NO) THEN
  1099.          IF (.NOT. CONFIRM(CMDFD)) RETURN
  1100.       ELSE
  1101.  
  1102. *        GET THE NOS CONTROL STATEMENT FROM THE COMMAND LINE.
  1103. *        MUST BE DONE BEFORE WRITING OUT THE ENVIRONMENT.
  1104.  
  1105.          OPOS = 1
  1106.          TERM = 46
  1107.  10      IF (GETC(CMDFD,CH) .EQ. NEL) THEN
  1108.             STR(OPOS+0) = TERM
  1109.             STR(OPOS+1) = 0
  1110.          ELSE
  1111.             IF (CH .NE. BLANK .OR. OPOS .GT. 1) THEN
  1112.                STR(OPOS) = CH
  1113.                OPOS = OPOS+1
  1114.             ENDIF
  1115.             IF (CH .EQ. 41 .OR. CH .EQ. 46) THEN
  1116.                TERM = 0
  1117.             ENDIF
  1118.             GOTO 10
  1119.          ENDIF
  1120.       ENDIF
  1121.  
  1122. *     WRITE OUT THE CURRENT ENVIRONMENT
  1123.  
  1124.       CALL MAKEFET('ZZZZKEN', FET, 6, BUFFER, 1000)
  1125.       CALL RETURN(FET, 1)
  1126.       CALL WRITEW(FET,HEADER,LOCF(TRAILER)-LOCF(HEADER),STATUS)
  1127.       CALL WRITER(FET, 1)
  1128.  
  1129. *     IF ONLY EXIT TO THE OPERATING SYSTEM
  1130.  
  1131.       IF (AUTORET .EQ. NO) THEN
  1132.          CALL EXITPGM
  1133.       ENDIF
  1134.  
  1135. *     QUIT IF NO COMMAND ENTERED
  1136.  
  1137.       IF (OPOS .EQ. 1) RETURN
  1138.  
  1139. *     PACK THE COMMAND INTO A *C* FORMAT LINE
  1140.  
  1141.       DO 20 I=1,80
  1142.          CMD(I:I) = ':'
  1143.  20   CONTINUE
  1144.       CALL AS2DPC(STR,CMD)
  1145.  
  1146. *     WRITE THE CCL PROCEDURE FILE AND BEGIN IT
  1147.  
  1148.       CALL RETFILE('ZZZZKCC')
  1149.       CALL EXE(CMD)
  1150.  
  1151.  
  1152.       END
  1153.       OVERLAY(3,0)
  1154.       PROGRAM KRM0300
  1155.  
  1156. ***   HLPCMD - PROCESS THE HELP COMMAND.
  1157. *
  1158.  
  1159.       IMPLICIT INTEGER (A-Z)
  1160.       PARAMETER (COMLIS = 0)
  1161.  
  1162. *CALL COMCKER
  1163.  
  1164.       PARAMETER (HFLAG = 45)
  1165.  
  1166.       CHARACTER WORD*20, RECWORD*20
  1167.       CHARACTER HELPPFN*10, HELPLFN*10, HELPUN*10
  1168.       INTEGER ASTR(21)
  1169.       LOGICAL CFE, SKIP
  1170.  
  1171.       DATA HELPPFN/'KERMHLP'/, HELPLFN/'ZZZZKHL'/, HELPUN/'LIBRARY'/
  1172.  
  1173. *     FIRST, GET THE HELP FILE.
  1174.  
  1175.       CALL PF('ATTACH', HELPLFN, HELPPFN, 'UN', HELPUN,
  1176.      +        'RC', REPLY, 'NA', ' ')
  1177.       IF(REPLY .NE. 0) THEN
  1178.          CALL FPRINTF(STDOUT,'^SORRY, BUT THE ^KERMIT HELP FILE'//
  1179.      +    ' IS NOT AVAILABLE\N',0,0,0,0)
  1180.          RETURN
  1181.       ENDIF
  1182.       HFD = FOPEN(HELPLFN, RD, CS612)
  1183.  
  1184. *     NEXT, GET THE KEYWORD AND SEARCH FOR MATCHING RECORD.
  1185.  
  1186.       LEN = GETWORD(CMDFD, ASTR, 20)
  1187.       IF(LEN .EQ. 0) THEN
  1188.          WORD = 'HELP'
  1189.          LEN = 4
  1190.       ELSE
  1191.          CALL AS2DPC(ASTR, WORD)
  1192.       ENDIF
  1193.       SKIP = .TRUE.
  1194.       LINES = 22
  1195.  
  1196. *     READ A LINE INTO 'PACKET' BUFFER.
  1197.  
  1198. 10    I = 1
  1199. 20    HELPEOF = GETC(HFD, CH)
  1200.       IF(HELPEOF .EQ. EOF) THEN
  1201.          GOTO 90
  1202.       ELSE
  1203.          PACKET(I) = CH
  1204.          I = I + 1
  1205.          IF(CH .NE. NEL) GOTO 20
  1206.          PACKET(I) = 0
  1207.       ENDIF
  1208.  
  1209. *     GOT FULL LINE.  SKIP, DISPLAY (22 LINES/PAGE), START DISPLAY,
  1210. *     OR EXIT.
  1211.  
  1212.       IF(PACKET(1) .NE. HFLAG) THEN
  1213.          IF(SKIP) THEN
  1214.          ELSE
  1215.             CALL PUTSTR(STDOUT, PACKET)
  1216.             LINES = LINES - 1
  1217.             IF(LINES .EQ. 0) THEN
  1218.                CALL FPRINTF(STDOUT, '@C\N',BELL,0,0,0)
  1219.                CALL FFLUSH(STDIN)
  1220. 30             CALL GETC(STDIN, CH)
  1221.                IF(CH .NE. NEL) GOTO 30
  1222.                LINES = 22
  1223.             ENDIF
  1224.          ENDIF
  1225.       ELSE
  1226.          IF(SKIP) THEN
  1227.             CALL AS2DPC(PACKET(2), RECWORD)
  1228.             IF(WORD(1:LEN) .EQ. RECWORD(1:LEN)) THEN
  1229.                SKIP = .FALSE.
  1230.             ENDIF
  1231.          ELSE
  1232.             GOTO 90
  1233.          ENDIF
  1234.       ENDIF
  1235.       GOTO 10
  1236.  
  1237. 90    CALL FCLOSE(HFD)
  1238.       CALL RETFILE(HELPLFN)
  1239.       RETURN
  1240.       END
  1241.       OVERLAY(4,0)
  1242.       PROGRAM KRM0400
  1243.  
  1244. ***   RCVFILE - TOP LEVEL SUBROUTINE TO START RECEIVE STATE.
  1245. *
  1246.  
  1247.       IMPLICIT INTEGER (A-Z)
  1248.       PARAMETER (COMLIS = 0)
  1249.  
  1250. *CALL COMCKER
  1251.  
  1252.       LOGICAL CONFIRM
  1253.  
  1254. *     CONFIRM THE COMMAND
  1255.  
  1256.       IF (.NOT. CONFIRM(CMDFD)) RETURN
  1257.  
  1258. *     ENSURE THERE IS NO JUNK IN THE FILE ARRAY.  THIS KEEPS 'REMOVE'
  1259. *     HAPPY, IN THE EVENT WE BLOW OFF BEFORE WE GET A FILE SPEC.
  1260.  
  1261.       CALL FPRINTF(STDOUT,'[^ESCAPE BACK TO MICRO TO ^S^E^N^D FILE(S).]
  1262.      +\N',0,0,0,0)
  1263.  
  1264.       DO 10 I = 1, IPKSIZE
  1265.           FILESTR(I) = 0
  1266. 10    CONTINUE
  1267.  
  1268. *     SET TERMINAL PARAMETERS
  1269.  
  1270.       CALL STTY('RCV-ON',0)
  1271.  
  1272. *     RECEIVE THE FILE
  1273.  
  1274.       IF (RECEIVE(R) .EQ. OK) THEN
  1275.          CALL FPRINTF(STDOUT,'^RECEIVE COMPLETE.\N',0,0,0,0)
  1276.       ELSE
  1277.          CALL FPRINTF(STDOUT,'^RECEIVE FAILED.\N',0,0,0,0)
  1278.       ENDIF
  1279.  
  1280. *     RESET TERMINAL PARAMETERS
  1281.  
  1282.       IF (INITDUP .EQ. FULLDUP) THEN
  1283.          CALL STTY('RCV-OFF',FULLDUP)
  1284.       ELSE
  1285.          CALL STTY('RCV-OFF',HALFDUP)
  1286.       ENDIF
  1287.  
  1288.  
  1289.       RETURN
  1290.       END
  1291.       OVERLAY(5,0)
  1292.       PROGRAM KRM0500
  1293.  
  1294. ***   SNDFILE - SEND A FILE TO OTHER KERMIT.
  1295. *
  1296.  
  1297.       IMPLICIT INTEGER (A-Z)
  1298.       PARAMETER (COMLIS = 0)
  1299.  
  1300. *CALL COMCKER
  1301.  
  1302.       LOGICAL GETFILE
  1303.       LOGICAL WILDSET
  1304.       CHARACTER*10 LFN
  1305.  
  1306.  
  1307. *     PICK UP THE FILE NAME AND SAVE IT FOR OPENING LATER
  1308.  
  1309.       CALL SETVAL(FILESTR,'S',IRET,9,0,0,HLPSNFN,.TRUE.)
  1310.       IF (IRET .EQ. ERROR) RETURN
  1311.  
  1312. *     GET POSSIBLE FILE TYPE AND MAKE SURE THE NAME IS LEGAL.
  1313.  
  1314.       CALL GETFTY(FILESTR, FTYPE)
  1315.       CALL AS2DPC(FILESTR,LFN)
  1316.       IF(.NOT.WILDSET(LFN)) THEN
  1317.          CALL FPRINTF(STDOUT,'?^ILLEGAL FILE NAME: "@S".\N',FILESTR,
  1318.      +                0,0,0)
  1319.          RETURN
  1320.       ENDIF
  1321.  
  1322. *     CHECK TO MAKE SURE THERE IS A FILE TO SEND SOMEWHERE
  1323.  
  1324.       IF(.NOT. GETFILE(FTYPE)) THEN
  1325.          CALL FPRINTF(STDOUT,'?^FILE "@S" NOT FOUND.\N',FILESTR,0,0,0)
  1326.          RETURN
  1327.       ENDIF
  1328.       CALL FPRINTF(STDOUT,'[^ESCAPE BACK TO MICRO TO RECEIVE ',0,0,0,0)
  1329.       IF(LOCFILE) THEN
  1330.          CALL FPRINTF(STDOUT,'LOCAL FILE(S).]\N',0,0,0,0)
  1331.       ELSE
  1332.          CALL FPRINTF(STDOUT,'PERMANENT FILE(S).]\N',0,0,0,0)
  1333.       ENDIF
  1334.  
  1335. *     SET TERMINAL PARAMETERS
  1336.  
  1337.       CALL STTY('RCV-ON',0)
  1338.  
  1339. *     DELAY THE FIRST PACKET
  1340.  
  1341.       IF (DELAYFP .GT. 0) CALL SLEEP(DELAYFP)
  1342.  
  1343. *     SEND THE FILE
  1344.  
  1345.       PACKNUM = 0
  1346.       IF (SEND(F, ' ') .EQ. OK) THEN
  1347.          CALL FPRINTF(STDOUT,'^SEND COMPLETE.\N',0,0,0,0)
  1348.       ELSE
  1349.          CALL FPRINTF(STDOUT,'^SEND FAILED.\N',0,0,0,0)
  1350.       ENDIF
  1351.  
  1352. *     RESET TERMINAL PARAMETERS
  1353.  
  1354.       IF (INITDUP .EQ. FULLDUP) THEN
  1355.          CALL STTY('RCV-OFF',FULLDUP)
  1356.       ELSE
  1357.          CALL STTY('RCV-OFF',HALFDUP)
  1358.       ENDIF
  1359.  
  1360.  
  1361.       RETURN
  1362.       END
  1363.       OVERLAY(6,0)
  1364.       PROGRAM KRM0600
  1365.  
  1366. ***   SET - SET SOME ATTRIBUTES.
  1367. *
  1368.  
  1369.       IMPLICIT INTEGER (A-Z)
  1370.       PARAMETER (COMLIS = 0)
  1371.  
  1372. *CALL COMCKER
  1373.  
  1374.       PARAMETER (TSIZE=10)
  1375.       CHARACTER*10 SETTYP(TSIZE)
  1376.       DATA SETTYP /  'DEBUG', 'DELAY', 'DUPLEX', 'FILE-MODE',
  1377.      +    'INIT-RETRY', 'RECEIVE', 'RDELAY', 'RETRY', 'SEND',
  1378.      +    'TEXT-MODE'/
  1379.  
  1380.  
  1381.       INDX = MATCH(SETTYP,TSIZE,.FALSE.)
  1382.       IF (INDX .LE. 0) RETURN
  1383.       GO TO (20, 30, 40, 10, 50, 70, 75, 80, 90, 100), INDX
  1384.  
  1385. *     SET CHARACTER SET
  1386.  
  1387. 10    CALL DMODCMD
  1388.       RETURN
  1389.  
  1390. *     SET DEBUGGING MODES
  1391.  
  1392. 20    CALL DBUGCMD
  1393.       RETURN
  1394.  
  1395. *     SET FIRST PACKET DELAY
  1396.  
  1397. 30    CALL SETVAL(DELAYFP,'I',0,30,0,30,HLPDLFP,.TRUE.)
  1398.       RETURN
  1399.  
  1400. *     SET THE DUPLEX
  1401.  
  1402. 40    CALL DPLXCMD
  1403.       RETURN
  1404.  
  1405. *     SET INTIAL PACKET RETRY COUNT
  1406.  
  1407. 50    CALL SETVAL(MAXRINI,'I',1,50,1,50,HLPIPRC,.TRUE.)
  1408.       RETURN
  1409.  
  1410. *     SET ATTRIBUTES WE REQUEST OF OTHER KERMIT
  1411.  
  1412. 70    CALL SETPACK(SPKSIZE)
  1413.       RETURN
  1414.  
  1415. *     SET READ DATA DELAY
  1416.  
  1417. 75    CALL SETVAL(RDELAY,'I',0,2000,0,2000,HLPRDEL,.TRUE.)
  1418.       RETURN
  1419.  
  1420. *     SET PACKET RETRY COUNT
  1421.  
  1422. 80    CALL SETVAL(MAXRTRY,'I',1,50,1,50,HLPPRTR,.TRUE.)
  1423.       RETURN
  1424.  
  1425. *     SET DEFAULT ATTRIBUTES USED WHEN SENDING TO OTHER KERMIT
  1426.  
  1427. 90    CALL SETPACK(DPKSIZE)
  1428.       RETURN
  1429.  
  1430. *     SET TEXT MODE (AUTO, 6/12, DISPLAY, 8/12)
  1431.  
  1432. 100   CALL TXTMCMD
  1433.       RETURN
  1434.  
  1435.       END
  1436.       OVERLAY(7,0)
  1437.       PROGRAM KRM0700
  1438.  
  1439. ***   SHOW - DISPLAY THE CURRENT PROGRAM SETTINGS
  1440. *
  1441.  
  1442.       IMPLICIT INTEGER (A-Z)
  1443.       PARAMETER (COMLIS = 0)
  1444.  
  1445. *CALL COMCKER
  1446.  
  1447.       LOGICAL CONFIRM
  1448.  
  1449. *CALL COMXKER
  1450.  
  1451.  
  1452. *     CONFIRM THE COMMAND
  1453.  
  1454.       IF (.NOT. CONFIRM(CMDFD)) RETURN
  1455.       CALL DPC2AS(VERSDAT, VERSSTR, 10)
  1456.       CALL FPRINTF(STDOUT,VERSION,VERSSTR,0,0,0)
  1457.  
  1458. *     DISPLAY THE CURRENT DATE AND TIME
  1459.  
  1460.       CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
  1461.       CALL PUTDAY(STDOUT,MM,DD,YY)
  1462.       CALL FPRINTF(STDOUT,', ',0,0,0,0)
  1463.       CALL PUTMNTH(STDOUT,MM)
  1464.       CALL FPRINTF(STDOUT,' @D, @D ',DD,YY,0,0)
  1465.       IF (HR .LT. 10) CALL PUTC(ASC('0'),STDOUT)
  1466.       CALL FPRINTF(STDOUT,'@D:',HR,0,0,0)
  1467.       IF (MIN .LT. 10) CALL PUTC(ASC('0'),STDOUT)
  1468.       CALL FPRINTF(STDOUT,'@D:',MIN,0,0,0)
  1469.       IF (SEC .LT. 10) CALL PUTC(ASC('0'),STDOUT)
  1470.       CALL FPRINTF(STDOUT,'@D\N\N',SEC,0,0,0)
  1471.  
  1472. *     DISPLAY DISK CHARACTER SET
  1473.  
  1474.       CALL FPRINTF(STDOUT,'  ^FILE-MODE: ',0,0,0,0)
  1475.       IF(FILMODE .EQ. TEXT) THEN
  1476.          CALL FPRINTF(STDOUT,'^TEXT (',0,0,0,0)
  1477.          IF(TXTMODE .EQ. CSNONE) THEN
  1478.             CALL FPRINTF(STDOUT,'AUTO)',0,0,0,0)
  1479.          ELSE IF(TXTMODE .EQ. CSDSP) THEN
  1480.             CALL FPRINTF(STDOUT,'DISPLAY)',0,0,0,0)
  1481.          ELSE IF(TXTMODE .EQ. CS612) THEN
  1482.             CALL FPRINTF(STDOUT,'6/12-ASCII)',0,0,0,0)
  1483.          ELSE IF(TXTMODE .EQ. CS812) THEN
  1484.             CALL FPRINTF(STDOUT,'8/12-ASCII)',0,0,0,0)
  1485.          ENDIF
  1486.       ELSE
  1487.          CALL FPRINTF(STDOUT,'^BINARY',0,0,0,0)
  1488.       ENDIF
  1489.  
  1490. *     DISPLAY THE CURRENT DUPLEX
  1491.  
  1492.       CALL FPRINTF(STDOUT,'           ^DUPLEX: ',0,0,0,0)
  1493.       IF (GTTY('DUPLEX') .EQ. FULLDUP) THEN
  1494.          CALL FPRINTF(STDOUT,'^FULL\N',0,0,0,0)
  1495.       ELSE
  1496.          CALL FPRINTF(STDOUT,'^HALF\N',0,0,0,0)
  1497.       ENDIF
  1498.  
  1499. *     DISPLAY CURRENT DEBUG MODES
  1500.  
  1501.       CALL FPRINTF(STDOUT,'  ^DEBUGGING: ',0,0,0,0)
  1502.       IF ((DEBUG.AND.DBGSTAT).NE.0) THEN
  1503.          IF ((DEBUG.AND.DBGPACK).NE.0) THEN
  1504.             CALL FPRINTF(STDOUT,'^STATES/^PACKETS',0,0,0,0)
  1505.          ELSE
  1506.             CALL FPRINTF(STDOUT,'^STATES        ',0,0,0,0)
  1507.          ENDIF
  1508.       ELSE
  1509.          IF ((DEBUG.AND.DBGPACK).NE.0) THEN
  1510.             CALL FPRINTF(STDOUT,'^PACKETS       ',0,0,0,0)
  1511.          ELSE
  1512.             CALL FPRINTF(STDOUT,'^OFF           ',0,0,0,0)
  1513.          ENDIF
  1514.       ENDIF
  1515.       IF (DEBUG .NE. DBGOFF) THEN
  1516.          CALL FPRINTF(STDOUT,'   ^LOG FILE: @S',DEBUGFN,0,0,0)
  1517.       ENDIF
  1518.  
  1519. *     DISPLAY PACKET SETTINGS
  1520.  
  1521.       CALL FPRINTF(STDOUT,'\N\N^PACKET ^PARAMETERS\N',0,0,0,0)
  1522.       CALL FPRINTF(STDOUT,
  1523.      +   '                    ^RECEIVE   ^SEND\N',0,0,0,0)
  1524.       CALL FPRINTF(STDOUT,'  ^SIZE:             @D        @D\N',
  1525.      +   SPKSIZE,DPKSIZE,0,0)
  1526.       CALL FPRINTF(STDOUT,'  ^TIMEOUT:          @D        @D\N',
  1527.      +   STIMOUT,DTIMOUT,0,0)
  1528.       CALL FPRINTF(STDOUT,'  ^PADDING:          @D',SPADCT,0,0,0)
  1529.       IF (SPADCT .LT. 10) CALL PUTC(BLANK,STDOUT)
  1530.       CALL FPRINTF(STDOUT,'        @D\N',DPADCT,0,0,0)
  1531.       CALL FPRINTF(STDOUT,'  ^PAD CHARACTER:    \^@C        \^@C\N',
  1532.      +   CTL(SPADCH),CTL(DPADCH),0,0)
  1533.       CALL FPRINTF(STDOUT,'  ^END-OF-^LINE:      \^@C        \^@C\N',
  1534.      +   CTL(SEOLCH),CTL(DEOLCH),0,0)
  1535.       CALL FPRINTF(STDOUT,'  ^CONTROL QUOTE:    @C         @C\N',
  1536.      +   SCQUOTE,DCQUOTE,0,0)
  1537.       CALL FPRINTF(STDOUT,'  ^EIGHT-BIT QUOTE:  @C         @C\N',
  1538.      +   S8QUOTE,D8QUOTE,0,0)
  1539.       CALL FPRINTF(STDOUT,'  ^REPEAT-PREFIX:    @C         @C\N',
  1540.      +   SRPTPFX,DRPTPFX,0,0)
  1541.       CALL FPRINTF(STDOUT,'  ^START-OF-^PACKET:  \^@C        \^@C\N',
  1542.      +   CTL(SSYNC),CTL(DSYNC),0,0)
  1543.  
  1544. *     DISPLAY PROTOCOL STUFF
  1545.  
  1546.       CALL FPRINTF(STDOUT,'\N^DELAY BEFORE SENDING FIRST PACKET: @D (SEC
  1547.      +ONDS)\N',DELAYFP,0,0,0)
  1548.       CALL FPRINTF(STDOUT,'^DELAY BEFORE EACH ^T^T^Y READ: @D (MILLISECO
  1549.      +NDS)\N',RDELAY,0,0,0)
  1550.       CALL FPRINTF(STDOUT,'^INIT PACKET RETRY COUNT: @D\N',MAXRINI,0,0,
  1551.      +0)
  1552.       CALL FPRINTF(STDOUT,'^PACKET RETRY COUNT: @D\N\N',MAXRTRY,0,0,0)
  1553.  
  1554.  
  1555.       RETURN
  1556.       END
  1557.       OVERLAY(10,0)
  1558.       PROGRAM KRM1000
  1559.  
  1560. ***   STATUS - TELL HOW LONG LAST TRANSFER TOOK.
  1561. *
  1562.  
  1563.       IMPLICIT INTEGER (A-Z)
  1564.       PARAMETER (COMLIS = 0)
  1565.  
  1566. *CALL COMCKER
  1567.  
  1568.       LOGICAL CONFIRM
  1569.  
  1570.  
  1571. *     CONFIRM THE COMMAND
  1572.  
  1573.       IF (.NOT. CONFIRM(CMDFD)) RETURN
  1574.  
  1575. *     DISPLAY STATISTICS FOR LAST TRANSFER
  1576.  
  1577.       CALL FPRINTF(STDOUT,
  1578.      +   '^MAX CHARACTERS IN PACKET: @D RECEIVED; @D SENT\N',SPKSIZE,
  1579.      +   RPKSIZE)
  1580.       IF (ENDTIM .LT. STARTIM) ENDTIM = ENDTIM + 86400
  1581.       NSEC = ENDTIM - STARTIM
  1582.       HR = NSEC / 3600
  1583.       NSEC = NSEC - (HR * 3600)
  1584.       MIN = NSEC / 60
  1585.       NSEC = NSEC - (MIN * 60)
  1586.       CALL FPRINTF(STDOUT,'^NUMBER OF CHARACTERS TRANSMITTED IN ',0,0)
  1587.       IF (HR  .GT. 0) CALL FPRINTF(STDOUT,'@D HOURS ',HR,0)
  1588.       IF (MIN .GT. 0) CALL FPRINTF(STDOUT,'@D MINUTES ',MIN,0)
  1589.       CALL FPRINTF(STDOUT,'@D SECONDS\N\N',NSEC,0)
  1590.       CALL FPRINTF(STDOUT,'             ^SENT:  @20D',SCHCNT,0)
  1591.       CALL FPRINTF(STDOUT,' ^OVERHEAD:  @D\N',SCHOVRH,0)
  1592.       CALL FPRINTF(STDOUT,'         ^RECEIVED:  @20D',RCHCNT,0)
  1593.       CALL FPRINTF(STDOUT,' ^OVERHEAD:  @D\N',RCHOVRH,0)
  1594.       CALL FPRINTF(STDOUT,'^TOTAL TRANSMITTED:  @20D',SCHCNT+RCHCNT,0)
  1595.       CALL FPRINTF(STDOUT,' ^OVERHEAD:  @D\N\N',SCHOVRH+RCHOVRH,0)
  1596.       CALL FPRINTF(STDOUT,
  1597.      +   '^TOTAL CHARACTERS TRANSMITTED PER SEC: @D\N',
  1598.      +   (SCHCNT+RCHCNT) / (ENDTIM-STARTIM),0)
  1599.       CALL FPRINTF(STDOUT,
  1600.      +   '^EFFECTIVE DATA RATE: @D BAUD\N\N', ((SCHCNT+RCHCNT) -
  1601.      +   (SCHOVRH+RCHOVRH)) / (ENDTIM-STARTIM) * 10,0)
  1602.       IF(ABORTYP .NE. 0) THEN
  1603.          CALL GETEMSG(PACKET)
  1604.          CALL FPRINTF(STDOUT,'?^KERMIT:  @S\N',PACKET,0)
  1605.       ENDIF
  1606.  
  1607.  
  1608.       RETURN
  1609.       END
  1610.       OVERLAY(11,0)
  1611.       PROGRAM KRM1100
  1612.  
  1613. ***   SERVER - START KERMIT SERVER
  1614. *
  1615. *     THE SERVER CAN CURRENTLY RESPOND TO THE FOLLOWING PACKETS: 
  1616. *
  1617. *        S  (SEND-INIT)
  1618. *        R  (RECEIVE-INIT)
  1619. *        GL (GENERIC LOGOUT)
  1620. *        GF (GENERIC FINISH)
  1621. *
  1622. *     OTHER PACKETS ARE REPLIED TO WITH AN E (ERROR) PACKET CONTAINING
  1623. *     AN "UNIMPLEMENTED SERVER COMMAND" MESSAGE.
  1624.  
  1625.  
  1626.       IMPLICIT INTEGER (A-Z)
  1627.       PARAMETER (COMLIS = 0)
  1628.  
  1629. *CALL COMCKER
  1630.  
  1631.       LOGICAL CONFIRM
  1632.  
  1633. *     CONFIRM THE COMMAND
  1634.  
  1635.       IF (.NOT. CONFIRM(CMDFD)) RETURN
  1636.  
  1637. *     SET TERMINAL PARAMETERS
  1638.  
  1639.       CALL STTY('RCV-ON',0)
  1640.  
  1641. *     INITIALIZE
  1642.  
  1643.       PACKNUM = 0
  1644.       NUMTRY = 0
  1645.       CALL FPRINTF(STDOUT,'[^KERMIT SERVER RUNNING ON ^CYBER HOST.  ^PLE
  1646.      +ASE TYPE YOUR ESCAPE SEQUENCE TO\N RETURN TO YOUR LOCAL MACHINE. ^
  1647.      +SHUT DOWN THE SERVER BY TYPING THE ^KERMIT ^B^Y^E \N OR ^F^I^N^I^S
  1648.      +^H COMMAND ON YOUR LOCAL MACHINE.]\N')
  1649.  
  1650.  
  1651. *     DON'T WAIT AROUND FOR SERVER PACKET; ALLOW SWAPOUT.
  1652.  
  1653. 10    WAITPAK = .FALSE.
  1654.       PTYP = RDPACK(LEN, NUM, RECPACK)
  1655.       WAITPAK = .TRUE.
  1656.       PACKNUM = NUM
  1657.       PSIZE = LEN
  1658.  
  1659. *     S E N D - I N I T
  1660.  
  1661.       IF (PTYP .EQ. S) THEN
  1662.          CALL OVERLAY('KRM1101', O"11", 1, 'RECALL', 1)
  1663.  
  1664. *     I N I T I A L I Z E
  1665.  
  1666.       ELSE IF (PTYP .EQ. EYE) THEN
  1667.          CALL OVERLAY('KRM1102', O"11", 2, 'RECALL', 1)
  1668. *     R E C E I V E - I N I T
  1669.  
  1670.       ELSE IF (PTYP .EQ. R) THEN
  1671.          CALL OVERLAY('KRM1103', O"11", 3, 'RECALL', 1)
  1672.  
  1673. *     A B O R T
  1674.  
  1675.       ELSE IF (PTYP .EQ. A) THEN
  1676.          IF(INITDUP .EQ. FULLDUP) THEN
  1677.             CALL STTY('RCV-OFF',FULLDUP)
  1678.          ELSE
  1679.             CALL STTY('RCV-OFF',HALFDUP)
  1680.          ENDIF
  1681.          RETURN
  1682.  
  1683. *     G E N E R I C
  1684.  
  1685.       ELSE IF (PTYP .EQ. G) THEN
  1686.          CALL OVERLAY('KRM1104', O"11", 4, 'RECALL', 1)
  1687. *        U N K N O W N
  1688.  
  1689.       ELSE
  1690.          IF (DEBUG .NE. 0) CALL FPRINTF(DEBUGFD,'SERVER: INVALID PACKET
  1691.      -TYPE\N')
  1692.          ABORTYP = INVALID.OR.READING.OR.SRVCMD
  1693.          CALL GETEMSG(ERRMSG(15))
  1694.          CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
  1695.  
  1696.       ENDIF
  1697.       GOTO 10
  1698.  
  1699.       END
  1700.       OVERLAY (11,1)
  1701.       PROGRAM KRM1101
  1702.  
  1703. ***   SERVER RECEIVE
  1704. *
  1705. *     THIS OVERLAY PROCESSES THE SEND-INIT PACKET FOR THE SERVER.
  1706. *
  1707.  
  1708.       IMPLICIT INTEGER (A-Z)
  1709.       PARAMETER (COMLIS = 0)
  1710.  
  1711. *CALL COMCKER
  1712.  
  1713.       CALL RDPARAM(RECPACK)
  1714.       CALL SNDPAR(Y,PACKET,PSIZE)
  1715.       CALL SNDPACK(Y,PACKNUM,PSIZE,PACKET)
  1716.       NUMTRY = 0
  1717.       PACKNUM = AND(PACKNUM+1,O"77")
  1718.       RECSTAT = RECEIVE(F)
  1719.       IF (DEBUG .NE. 0) THEN
  1720.          IF (RECSTAT .EQ. ERROR) THEN
  1721.             CALL FPRINTF(DEBUGFD,'^R^E^C^E^I^V^E ^F^A^I^L^E^D\N')
  1722.          ELSE
  1723.             CALL FPRINTF(DEBUGFD,'^R^E^C^E^I^V^E ^C^O^M^P^L^E^T^E\N')
  1724.          ENDIF
  1725.       ENDIF
  1726.       RETURN
  1727.  
  1728.       END
  1729.       OVERLAY (11,2)
  1730.       PROGRAM KRM1102
  1731.  
  1732. ***   SERVER INITIALIZE
  1733. *
  1734. *     THIS OVERLAY PROCESSES THE INITIALIZE PACKET FOR THE SERVER.
  1735. *
  1736.  
  1737.       IMPLICIT INTEGER (A-Z)
  1738.       PARAMETER (COMLIS = 0)
  1739.  
  1740. *CALL,COMCKER
  1741.  
  1742.       CALL RDPARAM(RECPACK)
  1743.       CALL SNDPAR(Y,PACKET,PSIZE)
  1744.       CALL SNDPACK(Y,PACKNUM,PSIZE,PACKET)
  1745.       RETURN
  1746.  
  1747.       END
  1748.       OVERLAY (11,3)
  1749.       PROGRAM KRM1103
  1750.  
  1751. ***   SERVER SEND
  1752. *
  1753. *     THIS OVERLAY PROCESSES THE RECEIVE-INIT PACKET FOR THE SERVER.
  1754. *
  1755.  
  1756.       IMPLICIT INTEGER (A-Z)
  1757.       PARAMETER (COMLIS = 0)
  1758.  
  1759. *CALL,COMCKER
  1760.  
  1761.       CHARACTER*10 LFN
  1762.       LOGICAL GETFILE, WILDSET
  1763.  
  1764.       CALL EXPSTR(RECPACK, PSIZE, FILESTR)
  1765.       CALL GETFTY(FILESTR, FTYPE)
  1766.       CALL AS2DPC(FILESTR,LFN)
  1767.       IF(.NOT.WILDSET(LFN)) THEN
  1768.          ABORTYP = INVFN
  1769.          CALL GETEMSG(ERRMSG(15))
  1770.          CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
  1771.       ELSE IF(.NOT.GETFILE(FTYPE)) THEN
  1772.          ABORTYP = NOTLCL
  1773.          CALL GETEMSG(ERRMSG(15))
  1774.          CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
  1775.       ELSE
  1776.          SNDSTAT = SEND(F, ' ')
  1777.          PACKNUM = 0
  1778.          IF (DEBUG .NE. 0) THEN
  1779.             IF (SNDSTAT .EQ. ERROR) THEN
  1780.                CALL FPRINTF(DEBUGFD,'^S^E^N^D ^F^A^I^L^E^D\N')
  1781.             ELSE
  1782.                CALL FPRINTF(DEBUGFD,'^S^E^N^D ^C^O^M^P^L^E^T^E\N')
  1783.             ENDIF
  1784.          ENDIF
  1785.       ENDIF
  1786.       RETURN
  1787.  
  1788.       END
  1789.       OVERLAY (11,4)
  1790.       PROGRAM KRM1104
  1791.  
  1792. ***   SERVER GENERIC FUNCTIONS
  1793. *
  1794. *     THIS OVERLAY PROCESSES THE GENERIC FUNCTIONS FOR THE SERVER.
  1795. *
  1796.  
  1797.       IMPLICIT INTEGER (A-Z)
  1798.       PARAMETER (COMLIS = 0)
  1799.  
  1800. *CALL,COMCKER
  1801.  
  1802. *CALL,COMXKER
  1803.  
  1804. *     L O G O U T
  1805.  
  1806.       IF (RECPACK(1) .EQ. L) THEN
  1807.          CALL SNDPACK(Y,PACKNUM,0,0)
  1808.          CALL LOGOUT
  1809.  
  1810. *     F I N I S H
  1811.  
  1812.       ELSE IF (RECPACK(1) .EQ. F) THEN
  1813.          CALL SNDPACK(Y,PACKNUM,0,0)
  1814.          CALL EXITPGM
  1815.  
  1816. *     D I R
  1817.  
  1818.       ELSE IF (RECPACK(1) .EQ. D) THEN
  1819.          IF(PSIZE .GE. 2) THEN
  1820.             CALL EXPSTR(RECPACK, PSIZE, FILESTR)
  1821.             L1 = UNCHAR(FILESTR(2))
  1822.             DO 20 L2 = 1, L1+1
  1823.  20         FILESTR(L2) = FILESTR(L2+2)
  1824.          ELSE
  1825.             L1 = 0
  1826.          ENDIF
  1827.          CALL RETFILE('ZZZZKDR')
  1828.          FD = FOPEN('ZZZZKDR', WR, CS612)
  1829.          CALL DIR(FD, L1)
  1830.          CALL FCLOSE(FD)
  1831.          CALL WILDSET('ZZZZKDR')
  1832.          CALL GETFILE(L)
  1833.          CALL SEND(X, 'KERMIT-170:')
  1834.          CALL RETFILE('ZZZZKDR')
  1835.          PACKNUM = 0
  1836.  
  1837. *     U N K N O W N
  1838.  
  1839.       ELSE
  1840.          ABORTYP = SRVCMD
  1841.          CALL GETEMSG(ERRMSG(15))
  1842.          CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
  1843.  
  1844.       ENDIF
  1845.       RETURN
  1846.  
  1847.       END
  1848.       OVERLAY (12,0)
  1849.       PROGRAM KRM1200
  1850.  
  1851. ***   DIR - EXECUTE THE 'DIRECTORY' COMMAND
  1852. *
  1853.  
  1854.       IMPLICIT INTEGER (A-Z)
  1855.       PARAMETER (COMLIS = 0)
  1856.  
  1857. *CALL,COMCKER
  1858.  
  1859. *     GET THE REQUESTED FILE STRING AND CALL THE DIR ROUTINE
  1860.  
  1861.       LEN = GETWORD(CMDFD, FILESTR, IPKSIZE)
  1862.       CALL DIR(STDOUT, LEN)
  1863.       RETURN
  1864.  
  1865.       END
  1866.       OVERLAY (13,0)
  1867.       PROGRAM KRM1300
  1868.  
  1869. ***   TAKE - EXECUTE THE 'TAKE' COMMAND
  1870. *
  1871. *     TAKE FILENAM      (TAKE COMMANDS FROM FILENAM)
  1872. *
  1873. *     WE WILL ACCEPT WILDCARDS, BUT WILL ONLY USE THE FIRST FILE.
  1874. *
  1875.  
  1876.       IMPLICIT INTEGER (A-Z)
  1877.       PARAMETER (COMLIS = 0)
  1878.  
  1879. *CALL,COMCKER
  1880.  
  1881.       LOGICAL WILDSET, GETFILE
  1882.  
  1883. *     GET THE REQUESTED FILE AND START TAKING INPUT FROM THERE.
  1884. *     IF CMDFD = -1, THIS IS A FAKE 'TAKE KERMINI' CALL AT STARTUP
  1885. *     TIME.
  1886. *     ANY ERRORS CAUSE TAKE TO REVERT TO STDIN FOR COMMAND INPUT.
  1887.  
  1888.       IF(CMDFD .LT. 0) THEN
  1889.          CALL DPC2AS('KERMINI', FILESTR, 7)
  1890.       ELSE
  1891.          IF(CMDFD .NE. STDIN) THEN
  1892.             CALL FCLOSE(CMDFD)
  1893.             CMDFD = STDIN
  1894.          ENDIF
  1895.          CALL SETVAL(FILESTR,'S',IRET,9,0,0,HLPSNFN,.TRUE.)
  1896.          IF(IRET .EQ. ERROR) RETURN
  1897.       ENDIF
  1898.  
  1899. *     GET FILE TYPE AND MAKE SURE THE NAME IS LEGAL.
  1900.  
  1901.       CALL GETFTY(FILESTR, FTYPE)
  1902.       CALL AS2DPC(FILESTR, CMDLFN)
  1903.       IF(.NOT.WILDSET(CMDLFN)) THEN
  1904.          CALL FPRINTF(STDOUT,'?^ILLEGAL FILE NAME: "@S".\N',FILESTR,
  1905.      +                0,0,0)
  1906.          CMDFD = STDIN
  1907.          RETURN
  1908.       ENDIF
  1909.  
  1910. *     GET THE FILE AND OPEN IT. IF 'KERMINI' CALL, DON'T OUTPUT ERROR
  1911. *     MESSAGE.
  1912.  
  1913.       IF(.NOT. GETFILE(FTYPE)) THEN
  1914.          IF(CMDFD .GT. 0) THEN
  1915.             CALL FPRINTF(STDOUT,'?^FILE "@S" NOT FOUND.\N',FILESTR,
  1916.      +                   0,0,0)
  1917.          ENDIF
  1918.          CMDFD = STDIN
  1919.          RETURN
  1920.       ENDIF
  1921.       CALL AS2DPC(FILESTR, CMDLFN)
  1922.       CMDFD = FOPEN(CMDLFN, RD, CS612)
  1923.       CMDLOCF = LOCFILE
  1924.       IF(CMDLOCF) THEN
  1925.          CALL FPRINTF(STDOUT,'[^TAKING COMMANDS FROM LOCAL FILE "@S"]\N'
  1926.      +           ,FILESTR,0,0,0)
  1927.       ELSE
  1928.          CALL FPRINTF(STDOUT,'[^TAKING COMMANDS FROM PERM FILE "@S"]\N'
  1929.      +           ,FILESTR,0,0,0)
  1930.       ENDIF
  1931.       RETURN
  1932.       END
  1933. *WEOR
  1934. *DECK KERMLIB
  1935.       SUBROUTINE AS2DPC(ASTR,DSTR)
  1936.  
  1937. ***   AS2DPC - TRANSLATE AN ASCII STRING BUFFER TO DPC CHAR STRING.
  1938. *
  1939. *     ASCII STRING IS TERMINATED BY A ZERO BYTE.
  1940.  
  1941.       IMPLICIT INTEGER (A-Z)
  1942.       PARAMETER (COMLIS = 0)
  1943.  
  1944. *CALL COMCKER
  1945.  
  1946.       BOOLEAN ASTR(*)
  1947.       CHARACTER DSTR*(*)
  1948.       INTEGER CLEN
  1949.  
  1950.  
  1951.       I = 1
  1952.       CLEN = LEN(DSTR)
  1953.       DSTR = ' '
  1954. 10    IF (ASTR(I) .NE. 0 .AND. I .LE. CLEN) THEN
  1955.          IF (ASTR(I) .GT. 127) THEN
  1956.             DSTR(I:I)=' '
  1957.          ELSE
  1958.             DSTR(I:I)=CHAR(DPCTBL(ASTR(I)))
  1959.          ENDIF
  1960.          I = I + 1
  1961.          GO TO 10
  1962.       ENDIF
  1963.  
  1964.  
  1965.       RETURN
  1966.       END
  1967.       INTEGER FUNCTION ASC(DPCH)
  1968.  
  1969. ***   ASC - CONVERT A DPC CHARACTER TO LOWER CASE ASCII.
  1970. *
  1971.  
  1972.       IMPLICIT INTEGER (A-Z)
  1973.       PARAMETER (COMLIS = 0)
  1974.  
  1975. *CALL COMCKER
  1976.  
  1977.       CHARACTER*1 DPCH
  1978.  
  1979.  
  1980.       ASC = LASCII(ICHAR(DPCH))
  1981.  
  1982.  
  1983.       RETURN
  1984.       END
  1985.       SUBROUTINE BUFEMP(BUFFER,FD,LEN)
  1986.  
  1987. ***   BUFEMP - DUMP A BUFFER TO A FILE.
  1988. *
  1989.  
  1990.       IMPLICIT INTEGER (A-Z)
  1991.       PARAMETER (COMLIS = 0)
  1992.  
  1993. *CALL COMCKER
  1994.  
  1995.       BOOLEAN BUFFER(*), CH
  1996.  
  1997. *CALL COMXKER
  1998.  
  1999.  
  2000. *     WRITE THE PACKET DATA TO THE FILE
  2001.  
  2002.       I = 1
  2003. 10    IF (I .LE. LEN) THEN
  2004.          CH = BUFFER(I)
  2005.  
  2006. *        REPEAT COUNTS
  2007. *
  2008. *        BY THE NATURE OF THE DATA PACKET (VISIBLE CHARACTERS ONLY),
  2009. *        CH CANNOT BE ZERO, SO IF REPEAT COUNTS ARE NOT BEING USED,
  2010. *        REPCH IS ZERO AND THE FOLLOWING TEST WILL ALWAYS BE FALSE.
  2011. *        THE TEST WILL BE TRUE IF AND ONLY IF REPEAT COUNTS ARE
  2012. *        BEING DONE AND CH=THE REPEAT COUNT PREFIX CHARACTER.
  2013.  
  2014.          IF (CH .EQ. REPCH) THEN
  2015.             REPCT = UNCHAR(BUFFER(I+1))
  2016.             I  = I+2
  2017.             CH = BUFFER(I)
  2018.          ELSE
  2019.             REPCT = 1
  2020.          ENDIF
  2021.  
  2022. *        8-BIT QUOTING
  2023. *
  2024. *        BY THE NATURE OF THE DATA PACKET (VISIBLE CHARACTERS ONLY),
  2025. *        CH CANNOT BE ZERO, SO IF 8-BIT QUOTING IS NOT BEING USED,
  2026. *        Q8CH IS ZERO AND THE FOLLOWING TEST WILL ALWAYS BE FALSE.
  2027. *        THE TEST WILL BE TRUE IF AND ONLY IF 8-BIT QUOTING IS
  2028. *        BEING DONE AND CH=THE 8-BIT QUOTE CHARACTER.
  2029.  
  2030.          IF (CH .EQ. Q8CH) THEN
  2031.             HIGHBIT = Z"80"
  2032.             I  = I+1
  2033.             CH = BUFFER(I)
  2034.          ELSE
  2035.             HIGHBIT = Z"00"
  2036.          ENDIF
  2037.  
  2038. *        CONTROL CHARACTER QUOTING
  2039. *
  2040. *        THIS CODE ALSO HANDLES THE CASE OF SPECIAL CHARACTER
  2041. *        QUOTING.  I.E. "##", "#&", AND "#<TILDE>" WILL BE CONVERTED
  2042. *        TO "#", "&", AND "<TILDE>", RESPECTIVELY.
  2043.  
  2044.          IF (CH .EQ. SCQUOTE) THEN
  2045.             I  = I+1
  2046.             CH = BUFFER(I)
  2047.             TCH = CTL(AND(CH,Z"7F"))
  2048.             IF (TCH .LT. BLANK .OR. TCH .EQ. DEL) CH = CTL(CH)
  2049.          ENDIF
  2050.  
  2051. *        SET THE HIGH BIT
  2052.  
  2053.          CH = OR(CH,HIGHBIT)
  2054.  
  2055. *        FOR TEXT FILES STRIP THE PARITY BIT AND CONVERT *CR*S TO
  2056. *        *NEL*S.  FOR BINARY FILES JUST WRITE THE CHARACTERS ASIS.
  2057.  
  2058.          DO 20 J=1,REPCT
  2059.             IF(FCSET(FD) .EQ. CSBIN) THEN
  2060.                CALL PUTC(CH,FD)
  2061.             ELSE
  2062.                CH = AND(CH,Z"7F")
  2063.                IF (CH .EQ. CR) THEN
  2064.                   CALL PUTC(NEL,FD)
  2065.                ELSE IF (CH .NE. LF) THEN
  2066.                   CALL PUTC(CH,FD)
  2067.                ENDIF
  2068.             ENDIF
  2069.  20      CONTINUE
  2070.  
  2071.          I = I+1
  2072.          GO TO 10
  2073.       ENDIF
  2074.  
  2075.  
  2076.       RETURN
  2077.       END
  2078.       INTEGER FUNCTION BUFFILL(FD,BUFFER)
  2079.  
  2080. ***   BUFFILL - GET SOME DATA TO SEND.
  2081. *
  2082. *     BUFFILL READS FROM THE FILE TO SEND AND PERFORMS ALL
  2083. *     THE PROPER ESCAPING OF CONTROL CHARACTERS AND MAPPING
  2084. *     NEWLINES INTO CRLF SEQUENCES.  IT ALSO GENERATES REPEAT
  2085. *     SEQUENCES.
  2086. *
  2087. *     ENTRY    (FD) = FILE DESCRIPTOR OF FILE TO READ FROM.
  2088. *              (BUFFER) = UNPACKED ASCII TRANSMISSION BUFFER.
  2089. *
  2090. *     EXIT     BUFFER FILLED WITH DATA FROM FILE IN KERMIT
  2091. *              TRANSMISSION FORMAT.
  2092.  
  2093. **    NOTE: THIS ALGORITHM ASSUMES 5 OVERHEAD CHARACTERS FOR THE
  2094. *     PACKET AND LEAVES 4 CHARACTERS IN CASE THE LAST CHARACTER
  2095. *     TO BUFFER IS A REPEATED CONTROL CHARACTER WITH THE HIGH
  2096. *     BIT SET.
  2097.  
  2098.       IMPLICIT INTEGER (A-Z)
  2099.       PARAMETER (COMLIS = 0)
  2100.  
  2101.       PARAMETER (MAXREP=94)
  2102.  
  2103. *CALL COMCKER
  2104.  
  2105.       BOOLEAN BUFFER(*)
  2106.  
  2107. *CALL COMXKER
  2108.  
  2109.  
  2110. *     FETCH THE FIRST CHARACTER
  2111.  
  2112.       IF (GETC(FD,CH1) .EQ. EOF) THEN
  2113.          BUFFER(1) = 0
  2114.          BUFFILL = EOF
  2115.          RETURN
  2116.       ENDIF
  2117.  
  2118. *     PREFETCH THE NEXT CHARACTER AND ADD THE CURRENT CHARACTER
  2119. *     TO THE BUFFER
  2120.  
  2121.       BUFPTR = 0
  2122.       REPCT = 1
  2123.  
  2124.  10   IF (CH1 .NE. EOF) THEN
  2125.          CH2 = GETC(FD,CH2)
  2126.  
  2127. *        COMPUTE BREAK-EVEN COUNT FOR REPEAT CHARACTERS
  2128.  
  2129.          IF (CH1 .LT. 32 .OR. CH1 .GT. 126) THEN
  2130.             MINREP = 2
  2131.          ELSE
  2132.             MINREP = 3
  2133.          ENDIF
  2134.  
  2135. *        ADD THE CHARACTER TO THE BUFFER
  2136.  
  2137.          IF (RRPTPFX .EQ. BLANK .OR. CH1 .EQ. NEL) THEN
  2138.             CALL BUFPACK(CH1,BUFFER,BUFPTR)
  2139.          ELSE IF (CH2 .EQ. CH1 .AND. REPCT .LT. MAXREP) THEN
  2140.             REPCT = REPCT+1
  2141.          ELSE IF (REPCT .GE. MINREP) THEN
  2142.             BUFFER(BUFPTR+1) = RRPTPFX
  2143.             BUFFER(BUFPTR+2) = TOCHAR(REPCT)
  2144.             BUFPTR = BUFPTR+2
  2145.             CALL BUFPACK(CH1,BUFFER,BUFPTR)
  2146.             REPCT = 1
  2147.          ELSE
  2148.             DO 20 I=1,REPCT
  2149.                CALL BUFPACK(CH1,BUFFER,BUFPTR)
  2150.  20         CONTINUE
  2151.             REPCT = 1
  2152.          ENDIF
  2153.          IF (BUFPTR .LT. RPKSIZE-9) THEN
  2154.             CH1 = CH2
  2155.             GOTO 10
  2156.          ELSE
  2157.             CALL UNGETC(FD,CH2)
  2158.          ENDIF
  2159.       ENDIF
  2160.  
  2161.       BUFFILL = BUFPTR
  2162.       BUFFER(BUFPTR+1) = 0
  2163.  
  2164.  
  2165.       RETURN
  2166.       END
  2167.       SUBROUTINE BUFPACK(TCH,BUFFER,BUFPTR)
  2168.  
  2169. ***   BUFPACK - ADD A CHARACTER TO THE TRANSMISSION BUFFER.
  2170. *
  2171. *     THIS ROUTINE ADDS A CHARACTER TO THE OUTGOING TRANSMISSION
  2172. *     BUFFER, CONVERTING <NEL> TO <CR><LF> PAIRS, AND DOING SPECIAL
  2173. *     CHARACTER, CONTROL CHARACTER, AND EIGHT-BIT QUOTING.
  2174. *
  2175. *     ENTRY    (TCH) = CHARACTER TO BE ADDED TO BUFFER.
  2176. *              (BUFFER) = UNPACKED ASCII BUFFER.
  2177. *              (BUFPTR) = POINTER TO LAST CHARACTER IN BUFFER.
  2178. *
  2179. *     EXIT     (BUFPTR) = UPDATED POINTER.
  2180. *              CHARACTER(S) ADDED TO BUFFER.
  2181.  
  2182.       IMPLICIT INTEGER (A-Z)
  2183.       PARAMETER (COMLIS = 0)
  2184.  
  2185. *CALL COMCKER
  2186.  
  2187.       BOOLEAN BUFFER(*)
  2188.  
  2189. *CALL COMXKER
  2190.  
  2191.  
  2192. *     CONVERT END OF LINE CHARACTER TO <CR><LF>
  2193.  
  2194.       IF (TCH .EQ. NEL) THEN
  2195.          BUFFER(BUFPTR+1) = RCQUOTE
  2196.          BUFFER(BUFPTR+2) = CTL(CR)
  2197.          BUFPTR = BUFPTR+2
  2198.          CH  = LF
  2199.          XCH = LF
  2200.       ELSE
  2201.          CH  = TCH
  2202.          XCH = AND(TCH,Z"7F")
  2203.       ENDIF
  2204.  
  2205. *     8-TH BIT QUOTING
  2206.  
  2207.       IF (Q8CH .NE. 0) THEN
  2208.  
  2209. *        CONVERT 'A TO &A
  2210.  
  2211.          IF (CH .GT. Z"7F") THEN
  2212.             BUFPTR = BUFPTR+1
  2213.             BUFFER(BUFPTR) = Q8CH
  2214.             CH = AND(CH,Z"7F")
  2215.          ENDIF
  2216.  
  2217. *        CONVERT & TO #&
  2218.  
  2219.          IF (CH .EQ. Q8CH) THEN
  2220.             BUFPTR = BUFPTR+1
  2221.             BUFFER(BUFPTR) = RCQUOTE
  2222.          ENDIF
  2223.       ENDIF
  2224.  
  2225. *     SPECIAL CHARACTER AND CONTROL CHARACTER QUOTING
  2226.  
  2227.       IF ((XCH .EQ. RCQUOTE) .OR.
  2228.      +    (XCH .EQ. RRPTPFX .AND. RRPTPFX .NE. BLANK)) THEN
  2229.  
  2230. *        CONVERT <TILDE> TO #<TILDE>
  2231. *        CONVERT # TO ##
  2232.  
  2233.          BUFPTR = BUFPTR+1
  2234.          BUFFER(BUFPTR) = RCQUOTE
  2235.  
  2236.       ELSE IF (XCH .LT. BLANK .OR. XCH .EQ. DEL) THEN
  2237.  
  2238. *        CONVERT <CC> TO #<CC>
  2239.  
  2240.          BUFPTR = BUFPTR+1
  2241.          BUFFER(BUFPTR) = RCQUOTE
  2242.          CH = CTL(CH)
  2243.       ENDIF
  2244.  
  2245.       BUFPTR = BUFPTR+1
  2246.       BUFFER(BUFPTR) = CH
  2247.  
  2248.       RETURN
  2249.       END
  2250.           IDENT  CFE
  2251.           ENTRY  CFE
  2252.           SST
  2253.           SYSCOM B1
  2254.  CFE      TITLE  CFE - CHECK FILES EXISTANCE.
  2255.           COMMENT CHECK FILES EXISTANCE.
  2256.  CFE      SPACE  4,10
  2257. **        CFE - CHECK FILES EXISTANCE.
  2258. *
  2259. *         LOGICAL CFE, RESULT
  2260. *
  2261. *         RESULT =  CFE(LFN)
  2262. *
  2263. *         ENTRY  (LFN) = IS THE CHARACTER*7 FILE NAME.
  2264. *
  2265. *         EXIT   (RESULT) = .TRUE. IF FILE EXISTS.
  2266. *                (RESULT) = .FALSE. OTHERWISE.
  2267.  
  2268.  
  2269.  CFE      SUBR               ENTRY/EXIT
  2270.           SB1    1
  2271.           SA1    X1          (X1) = FILE NAME
  2272.           RJ     =XBTZ>      CONVERT BLANKS TO 00B
  2273.           SX1    B1          SET COMPLETE BIT
  2274.           BX6    X6+X1
  2275.           SA6    CFEA
  2276.           STATUS CFEA
  2277.           MX6    0           ASSUME NO FILE (.FALSE.)
  2278.           MX1    11
  2279.           LX1    12          (X1) = LOW BITS MASK
  2280.           SA2    CFEA
  2281.           BX2    X1*X2       (X2) = 0 IF FILE NOT FOUND
  2282.           ZR     X2,CFEX     IF NO FILE
  2283.           MX6    -1          SET FILE FOUND (.TRUE.)
  2284.           EQ     CFEX        RETURN
  2285.  
  2286.  CFEA     DATA   0           FET
  2287.  
  2288.           END
  2289.       LOGICAL FUNCTION CONFIRM(FD)
  2290.  
  2291. ***   CONFIRM - LOOK FOR A NEWLINE.
  2292. *
  2293. *     CONFIRM WILL EXPECT THAT THE NEXT TOKEN OF INPUT BE A
  2294. *     NEWLINE FOR CONFIRMATION TO BE TRUE.  IF THE NEXT TOKEN
  2295. *     IS A QUESTION MARK, THEN CONFIRMATION IS FALSE AND
  2296. *     A "CONFIRM WITH A CARRIAGE RETURN" MESSAGE WILL BE DISPLAYED.
  2297. *     ANY OTHER TEXT WILL CAUSE A 'NOT CONFIRMED "TEXT"' MESSAGE
  2298. *     TO BE DISPLAYED AND CONFIRM WILL RETURN FALSE.
  2299.  
  2300.       IMPLICIT INTEGER (A-Z)
  2301.       PARAMETER (COMLIS = 0)
  2302.  
  2303. *CALL COMCKER
  2304.  
  2305.  
  2306. *     GET LEADING BLANKS TIL A TOKEN IS FOUND
  2307.  
  2308.       CONFIRM = .FALSE.
  2309.  10   IF (GETC(FD,CH) .EQ. NEL) THEN
  2310.          CONFIRM = .TRUE.
  2311.       ELSE IF (CH .EQ. EOF) THEN
  2312.          RETURN
  2313.       ELSE IF (CH .EQ. BLANK .OR. CH .EQ. TAB) THEN
  2314.          GO TO 10
  2315.       ELSE IF (CH .EQ. QMARK) THEN
  2316.          CALL FPRINTF(STDOUT,'^CONFIRM WITH A CARRIAGE RETURN\N')
  2317.       ELSE
  2318.          CALL FPRINTF(STDOUT,'?^NOT CONFIRMED - "')
  2319.  20      CALL PUTC(CH,STDOUT)
  2320.          CH = GETC(FD,CH)
  2321.          IF (CH .NE. NEL .AND. CH .NE. EOF) GO TO 20
  2322.          CALL FPRINTF(STDOUT,'"\N')
  2323.       ENDIF
  2324.  
  2325.  
  2326.       RETURN
  2327.       END
  2328.       INTEGER FUNCTION CTOI(ASTR)
  2329.  
  2330. ***   CTOI - CONVERT CHARACTER BUFFER TO INTEGER.
  2331. *
  2332. *     CTOI CONVERTS THE NUMBER USING BASE 10 AS A DEFAULT.
  2333. *     A SUFFIX OF H WILL CONVERT USING BASE 16 AND A SUFFIX
  2334. *     OF O WILL CONVERT USING BASE 8.  DEFAULT SUFFIX IS
  2335. *     D.
  2336.  
  2337.       IMPLICIT INTEGER (A-Z)
  2338.       PARAMETER (COMLIS = 0)
  2339.  
  2340. *CALL COMCKER
  2341.  
  2342.       PARAMETER (DIG0=48, DIG7=55, DIG9=57, BIGA=65, BIGB=66, BIGD=68)
  2343.       PARAMETER (BIGF=70, BIGH=72, BIGO=79, LETA=97, LETB=98, LETD=100)
  2344.       PARAMETER (LETF=102, LETH=104, LETO=111)
  2345.       INTEGER ASTR(*)
  2346.  
  2347.  
  2348.       BASE = 0
  2349.       PTR = 0
  2350.  
  2351. *     FIND LAST VALID DIGIT
  2352.  
  2353. 10    PTR = PTR + 1
  2354.       IF (ASTR(PTR) .NE. 0) GO TO 10
  2355.       PTR = PTR - 1
  2356.       IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.
  2357.      +    ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB .OR.
  2358.      +    ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN
  2359.          EOD = PTR - 1
  2360.       ELSE
  2361.          EOD = PTR
  2362.          PTR = PTR + 1
  2363.       ENDIF
  2364.  
  2365. *     TRY TO FIGURE OUT THE BASE
  2366.  
  2367.       IF (ASTR(PTR) .EQ. 0) THEN
  2368.          BASE = 10
  2369.       ELSE IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.
  2370.      +         ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB) THEN
  2371.          BASE = 8
  2372.       ELSE IF (ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN
  2373.          BASE = 16
  2374.       ENDIF
  2375.  
  2376. *     IF DIDN'T FIND A BASE
  2377.  
  2378.       IF (BASE .EQ. 0) THEN
  2379.          CALL FPRINTF(STDOUT,'CTOI - INVALID BASE @C\N',ASTR(PTR),0,0,0)
  2380.          CTOI = 0
  2381.          RETURN
  2382.       ENDIF
  2383.  
  2384. *     ADD UP THE DIGITS
  2385.  
  2386.       TOTAL = 0
  2387.       ISNEG = 1
  2388.       DO 100 I = 1,EOD
  2389.          CH = ASTR(I)
  2390.          IF (CH .EQ. MINUS) THEN
  2391.             ISNEG = -1
  2392.             GO TO 100
  2393.          ENDIF
  2394.          IF (BASE .EQ. 10) THEN
  2395.             IF (CH .LT. DIG0 .OR. CH .GT. DIG9) THEN
  2396.                CALL FPRINTF(STDOUT,'CTOI - INVALID DECIMAL DIGIT @C\N',
  2397.      +                      CH,0,0,0)
  2398.                CTOI = 0
  2399.                RETURN
  2400.             ELSE
  2401.                CH = CH - DIG0
  2402.             ENDIF
  2403.          ELSE IF (BASE .EQ. 8) THEN
  2404.             IF (CH .LT. DIG0 .OR. CH .GT. DIG7) THEN
  2405.                CALL FPRINTF(STDOUT,'CTOI - INVALID OCTAL DIGIT @C\N',
  2406.      +                      CH,0,0,0)
  2407.                CTOI = 0
  2408.                RETURN
  2409.             ELSE
  2410.                CH = CH - DIG0
  2411.             ENDIF
  2412.          ELSE IF (BASE .EQ. 16) THEN
  2413.             IF (CH .GE. DIG0 .AND. CH .LE. DIG9) THEN
  2414.                CH = CH - DIG0
  2415.             ELSE IF (CH .GE. LETA .AND. CH .LE. LETF) THEN
  2416.                CH = 10 + CH - LETA
  2417.             ELSE IF (CH .GE. BIGA .AND. CH .LE. BIGF) THEN
  2418.                CH = 10 + CH - BIGA
  2419.             ELSE
  2420.                CALL FPRINTF(STDOUT,'CTOI - INVALID HEX DIGIT @C\N',
  2421.      +                      CH,0,0,0)
  2422.                CTOI = 0
  2423.                RETURN
  2424.             ENDIF
  2425.          ENDIF
  2426.          TOTAL = TOTAL*BASE + CH
  2427. 100   CONTINUE
  2428.       CTOI = TOTAL * ISNEG
  2429.  
  2430.  
  2431.       RETURN
  2432.       END
  2433.       SUBROUTINE DBUGCMD
  2434.  
  2435. ***   DBUGCMD - SET THE DEBUGGING MODES.
  2436. *
  2437.  
  2438.       IMPLICIT INTEGER (A-Z)
  2439.       PARAMETER (COMLIS = 0)
  2440.  
  2441. *CALL COMCKER
  2442.  
  2443.       CHARACTER*10 FN
  2444.       LOGICAL CONFIRM
  2445.       PARAMETER (TSIZE=5)
  2446.       CHARACTER*10 DBGTYP(TSIZE)
  2447.       DATA DBGTYP / 'ALL', 'LOG-FILE', 'OFF', 'PACKETS', 'STATES' /
  2448.  
  2449.  
  2450.       INDX = MATCH(DBGTYP,TSIZE,.FALSE.)
  2451.       IF (INDX .LE. 0) RETURN
  2452.       GO TO (10, 20, 30, 40, 50), INDX
  2453.  
  2454. *     SET ALL DEBUG MODES
  2455.  
  2456. 10    IF (.NOT. CONFIRM(CMDFD)) RETURN
  2457.       DEBUG = DBGALL
  2458.       GO TO 100
  2459.  
  2460. *     SET DEBUG LOGFILE
  2461.  
  2462. 20    CALL SETVAL(DEBUGFN,'S',IRET,7,0,0,HLPDBFN,.TRUE.)
  2463.       IF (IRET .EQ. OK) THEN
  2464.          IF (DEBUGFD .NE. 0) THEN
  2465.             CALL FCLOSE(DEBUGFD)
  2466.             DEBUGFD = 0
  2467.          ENDIF
  2468.          GO TO 100
  2469.       ENDIF
  2470.       RETURN
  2471.  
  2472. *     TURN OFF ALL DEBUGGING
  2473.  
  2474. 30    IF (.NOT. CONFIRM(CMDFD)) RETURN
  2475.       DEBUG = DBGOFF
  2476.       IF (DEBUGFD .NE. 0) THEN
  2477.          CALL FCLOSE(DEBUGFD)
  2478.          DEBUGFD = 0
  2479.       ENDIF
  2480.       RETURN
  2481.  
  2482. *     TOGGLE DEBUG PACKETS
  2483.  
  2484. 40    IF (.NOT. CONFIRM(CMDFD)) RETURN
  2485.       DEBUG = DEBUG .XOR. DBGPACK
  2486.       GO TO 100
  2487.  
  2488. *     TOGGLE DEBUG STATES
  2489.  
  2490. 50    IF (.NOT. CONFIRM(CMDFD)) RETURN
  2491.       DEBUG = DEBUG .XOR. DBGSTAT
  2492.       GO TO 100
  2493.  
  2494. *     OPEN THE DEBUG FILE IF NOT DONE ALREADY
  2495.  
  2496. 100   IF (DEBUGFD .EQ. 0) THEN
  2497.          FN = ' '
  2498.          CALL AS2DPC(DEBUGFN,FN)
  2499.          DEBUGFD = FOPEN(FN,WR,CS612)
  2500.       ENDIF
  2501.  
  2502.  
  2503.       RETURN
  2504.       END
  2505.       SUBROUTINE DELAY(MSEC)
  2506.  
  2507. ***   DELAY - DELAY FOR A FEW MILLISECONDS.
  2508. *
  2509. *     ENTRY   MSEC = DELAY TIME IN MILLISECONDS.
  2510. *
  2511. *     EXIT    TIME HAS ELAPSED.
  2512. *
  2513. *     NOTES   WORKS FOR SCOPE, UT2D, AND NOS/BE SYSTEMS.  NOS USERS MUST
  2514. *             CHANGE THE COMPUTATION TO ACCOUNT FOR THE DIFFERENCE
  2515. *             IN DATA RETURNED BY RTIME MACRO.
  2516.  
  2517.       IMPLICIT INTEGER (A-Z)
  2518.       PARAMETER (COMLIS = 0)
  2519.  
  2520. *CALL COMCKER
  2521.  
  2522.  
  2523. *    USE REAL TIME CLOCK TO CONTROL DELAY PERIOD.
  2524.  
  2525.       CALL RTIME(RTCL)
  2526.       RTCL = AND(RTCL,COMPL(MASK(24)))
  2527. 10    CALL RTIME(RTCL1)
  2528.       RTCL1 = AND(RTCL1,COMPL(MASK(24)))
  2529.  
  2530. *     CONVERT FROM SECONDS/4096 TO MILLISECONDS.
  2531.  
  2532.       IF((RTCL1-RTCL).GT.MSEC) RETURN
  2533.  
  2534. *     SLEEP FOR 100 MILLISECONDS.
  2535.  
  2536.       CALL RECALL(0)
  2537.       GO TO 10
  2538.  
  2539.       END
  2540.       SUBROUTINE DIR(FD, LEN)
  2541.  
  2542. ***   DIR - CREATE DIRECTORY LISTING ON SPECIFIED FILE.
  2543. *
  2544. *     ENTRY FD - OUTPUT FILE DESCRIPTOR
  2545. *           LEN - LENGTH OF STRING IN 'FILESTR' ARRAY.
  2546. *           FILESTR CONTAINS FILE REQUEST STRING: 
  2547. *              FILENAM
  2548. *              FILE*          (WILDCARD LOCAL FILES)
  2549. *              L:* OR L:      (ALL LOCAL FILES)
  2550. *              P:* OR P:      (ALL PERMANENT FILES)
  2551. *              P:FILE*        (WILDCARD PERMANENT FILES)
  2552. *     EXIT  FILE CONTAINS DIRECTORY OUTPUT.
  2553. *
  2554.       IMPLICIT INTEGER (A-Z)
  2555.       PARAMETER (COMLIS = 0)
  2556.  
  2557. *CALL COMCKER
  2558.  
  2559.       CHARACTER FILENAM*10
  2560.       LOGICAL WILDSET
  2561.  
  2562.       FILESTR(LEN+1) = 0
  2563.  
  2564. *     CHECK FOR L: OR P:, REMOVE AND FLAG IF PRESENT.
  2565. *     MOVE REST OF REQUEST STRING TO RIGHT PLACE.
  2566.  
  2567.       CALL GETFTY(FILESTR, FTYPE)
  2568.       IF(SLEN(FILESTR) .EQ. 0) THEN
  2569.          FILENAM = '*'
  2570.       ELSE
  2571.          CALL AS2DPC(FILESTR, FILENAM)
  2572.       ENDIF
  2573.       LOCFILE = (FTYPE .NE. P)
  2574.  
  2575.       IF(.NOT.WILDSET(FILENAM)) THEN
  2576.          CALL FPRINTF(FD,'? ^INVALID FILE NAME STRING. \N',0,0,0,0)
  2577.          RETURN
  2578.       ENDIF
  2579.  
  2580. *     WE KNOW WHAT TO GET A DIRECTORY OF.  NOW DO IT.
  2581.  
  2582.       PACKET(1) = BLANK
  2583.  
  2584.       IF(LOCFILE) THEN
  2585.          CALL GETLFNI
  2586.          CALL FPRINTF(FD,'^DIRECTORY OF ^LOCAL FILES.\N',0,0,0,0)
  2587.       ELSE
  2588.          CALL GETPFNI
  2589.          CALL FPRINTF(FD,'^DIRECTORY OF ^PERMANENT FILES.\N',0,0,0,0)
  2590.       ENDIF
  2591.  
  2592.       I1 = 0
  2593. 10    IF(LOCFILE) THEN
  2594.          CALL GETLFN(FILENAM)
  2595.       ELSE
  2596.          CALL GETPFN(FILENAM)
  2597.       ENDIF
  2598.       IF(FILENAM .NE. ' ') THEN
  2599.          CALL DPC2AS(FILENAM, PACKET(2), 9)
  2600.          CALL PUTSTR(FD, PACKET)
  2601.          I1 = I1 + 1
  2602.          IF(MOD(I1, 7) .EQ. 0) THEN
  2603.             CALL PUTC(NEL, FD)
  2604.          ENDIF
  2605.          GOTO 10
  2606.       ELSE
  2607.          IF(I1 .EQ. 0) THEN
  2608.             CALL FPRINTF(FD,'? ^NO FILES FOUND. \N',0,0,0,0)
  2609.          ELSE IF(I1 .EQ. 1) THEN
  2610.             CALL FPRINTF(FD,'\N 1 FILE FOUND.\N',0,0,0,0)
  2611.          ELSE
  2612.             CALL FPRINTF(FD,'\N @D FILES FOUND.\N',I1,0,0,0)
  2613.          ENDIF
  2614.       ENDIF
  2615.       RETURN
  2616.       END
  2617.       SUBROUTINE DMODCMD
  2618.  
  2619. ***   DMODCMD - PERFORM A SET FILE-MODE XXXX COMMAND.
  2620. *
  2621.  
  2622.       IMPLICIT INTEGER (A-Z)
  2623.       PARAMETER (COMLIS = 0)
  2624.  
  2625. *CALL COMCKER
  2626.  
  2627.       LOGICAL CONFIRM
  2628.       PARAMETER (TSIZE=2)
  2629.       CHARACTER*15 DATATYP(TSIZE)
  2630.       DATA DATATYP /'BINARY','TEXT'/
  2631.  
  2632.  
  2633. *     MATCH THE PARAMETER.
  2634.  
  2635.       INDX = MATCH(DATATYP,TSIZE,.FALSE.)
  2636.       IF (INDX .LE. 0) RETURN
  2637.       IF (.NOT. CONFIRM(CMDFD)) RETURN
  2638.  
  2639. *     TAKE THE APPROPRIATE ACTION.
  2640.  
  2641.       GO TO (10,20), INDX
  2642.  
  2643. *     SET BINARY TRANSFER MODE
  2644.  
  2645.  10   FILMODE = BINARY
  2646.       RETURN
  2647.  
  2648. *     SET TEXT TRANSFER MODE
  2649.  
  2650.  20   FILMODE = TEXT
  2651.       RETURN
  2652.  
  2653.       END
  2654.       SUBROUTINE DOPRNT(FD,STRNG,PTYP,FMT,I1,I2,I3,I4)
  2655.  
  2656. ***   DOPRNT - WORKHORSE FOR FORMATTED ASCII I/O.
  2657. *
  2658. *     CONVERSION IS SIMILAR TO FPRINTF USED IN C.  SUPPORTED
  2659. *     CONVERSIONS ARE @D (INTEGER), @C (ASCII CHARACTER), @S (ASCII
  2660. *     STRING BUFFER).  A \N WILL MAP TO A NEWLINE, A \T WILL
  2661. *     WILL MAP TO A TAB, A \0 WILL TERMINATE THE FORMAT SCANNING.
  2662. *     A \ FOLLOWED BY ANY OTHER CHARACTER WILL CAUSE THAT CHARACTER
  2663. *     TO BE OUTPUT.  THE DEFAULT OUTPUT CASE WILL BE LOWERCASE.
  2664. *     A ^ FOLLOWED BY A LETTER WILL CAUSE THAT CHARACTER TO BE OUTPUT
  2665. *     AS UPPERCASE.  A @D CONVERSION MAY NOW SPECIFY A MINIMUM FIELD
  2666. *     WIDTH AS @<N>D (I.E. @10D) IN WHICH THE NUMBER WILL BE BLANK
  2667. *     PADDED TO THE RIGHT TO USE UP <N> CHARACTERS.
  2668.  
  2669.       IMPLICIT INTEGER (A-Z)
  2670.       PARAMETER (COMLIS = 0)
  2671.  
  2672. *CALL COMCKER
  2673.  
  2674.       CHARACTER*(*) FMT
  2675.       BOOLEAN STR(21), STRNG(*)
  2676.       CHARACTER*1 CH
  2677.  
  2678.  
  2679. *     CHECK FOR FILE OR STRING WRITE
  2680.  
  2681.       IF (PTYP .NE. 1 .AND. PTYP .NE. 2) THEN
  2682.          CALL DISPLA(' DOPRNT - INVALID WRITE FUNCTION',PTYP)
  2683.          CALL ABORT
  2684.       ENDIF
  2685.  
  2686. *     OUTPUT THE FORMATTED STRING
  2687.  
  2688.       IPTR = 1
  2689.       OPTR = 1
  2690.       FPTR = 1
  2691.       FMTLEN = LEN(FMT)
  2692. 10    IF (FPTR .LE. FMTLEN) THEN
  2693.          CH = FMT(FPTR:FPTR)
  2694.          IF (CH .NE. '\' .AND. CH .NE. '@' .AND. CH .NE. '^') THEN
  2695.             IF (PTYP .EQ. 1) THEN
  2696.                CALL PUTC(ASC(CH),FD)
  2697.             ELSE
  2698.                STRNG(OPTR) = ASC(CH)
  2699.                OPTR = OPTR + 1
  2700.             ENDIF
  2701.  
  2702. *        IS IT A QUOTE OR SPECIAL SEQUENCE CHARACTER?
  2703.  
  2704.          ELSE IF (CH .EQ. '\') THEN
  2705.             FPTR = FPTR+1
  2706.             CH = FMT(FPTR:FPTR)
  2707.             IF (CH .EQ. 'N' .AND. PTYP .EQ. 1) THEN
  2708.                CALL PUTC(NEL,FD)
  2709.             ELSE IF (CH .EQ. 'T' .AND. PTYP .EQ. 1) THEN
  2710.                CALL PUTC(TAB,FD)
  2711.             ELSE IF (CH .EQ. '0') THEN
  2712.                IF (PTYP .EQ. 2) STRNG(OPTR) = 0
  2713.                RETURN
  2714.             ELSE IF (CH .EQ. 'N') THEN
  2715.                STRNG(OPTR) = NEL
  2716.                OPTR = OPTR + 1
  2717.             ELSE IF (CH .EQ. 'T') THEN
  2718.                STRNG(OPTR) = TAB
  2719.                OPTR = OPTR + 1
  2720.             ELSE
  2721.                IF (PTYP .EQ. 1) THEN
  2722.                   CALL PUTC(ASC(CH),FD)
  2723.                ELSE
  2724.                   STRNG(OPTR) = ASC(CH)
  2725.                   OPTR = OPTR + 1
  2726.                ENDIF
  2727.             ENDIF
  2728.  
  2729. *     IS IT AN UPPERCASE MAPPING?
  2730.  
  2731.          ELSE IF (CH .EQ. '^') THEN
  2732.             FPTR = FPTR + 1
  2733.             CH = FMT(FPTR:FPTR)
  2734.             IF (CH .GE. 'A' .AND. CH .LE. 'Z') THEN
  2735.                ACH = ASC(CH)-32
  2736.             ELSE
  2737.                ACH = ASC(CH)
  2738.             ENDIF
  2739.             IF (PTYP .EQ. 1) THEN
  2740.                CALL PUTC(ACH,FD)
  2741.             ELSE
  2742.                STRNG(OPTR) = ACH
  2743.                OPTR = OPTR + 1
  2744.             ENDIF
  2745.  
  2746. *        MUST BE A CONVERSION (@)
  2747.  
  2748.          ELSE
  2749.             INTWDTH = 1
  2750.             FPTR = FPTR + 1
  2751.             CH = FMT(FPTR:FPTR)
  2752.  
  2753. *           IS IT AN INTEGER VALUE FORMAT SPEC?
  2754.  
  2755. 20          IF (CH .EQ. 'D') THEN
  2756.                IF (IPTR .EQ. 1) THEN
  2757.                   ACH = I1
  2758.                ELSE IF (IPTR .EQ. 2) THEN
  2759.                   ACH = I2
  2760.                ELSE IF (IPTR .EQ. 3) THEN
  2761.                   ACH = I3
  2762.                ELSE
  2763.                   ACH = I4
  2764.                ENDIF
  2765.                IF (PTYP .EQ. 1) THEN
  2766.                   CALL PUTINT(FD,ACH,INTWDTH)
  2767.                ELSE
  2768.                   TLEN = ITOS(ACH,STRNG(OPTR),INTWDTH)
  2769.                   OPTR = OPTR + TLEN
  2770.                ENDIF
  2771.                IPTR = IPTR + 1
  2772.  
  2773. *           IS IT A CHARACTER VALUE OUTPUT SPEC?
  2774.  
  2775.             ELSE IF (CH .EQ. 'C') THEN
  2776.                IF (IPTR .EQ. 1) THEN
  2777.                   ACH = I1
  2778.                ELSE IF (IPTR .EQ. 2) THEN
  2779.                   ACH = I2
  2780.                ELSE IF (IPTR .EQ. 3) THEN
  2781.                   ACH = I3
  2782.                ELSE
  2783.                   ACH = I4
  2784.                ENDIF
  2785.                IF (PTYP .EQ. 1) THEN
  2786.                   CALL PUTC(ACH,FD)
  2787.                ELSE
  2788.                   STRNG(OPTR) = ACH
  2789.                   OPTR = OPTR + 1
  2790.                ENDIF
  2791.                IPTR = IPTR + 1
  2792.  
  2793. *           IS IT A STRING VALUE OUTPUT SPEC?
  2794.  
  2795.             ELSE IF (CH .EQ. 'S') THEN
  2796.                IF (IPTR .EQ. 1) THEN
  2797.                   IF (PTYP .EQ. 1) THEN
  2798.                      CALL PUTSTR(FD,I1)
  2799.                   ELSE
  2800.                      CALL STRCPY(I1,STRNG(OPTR))
  2801.                      OPTR = OPTR + SLEN(I1)
  2802.                   ENDIF
  2803.                ELSE IF (IPTR .EQ. 2) THEN
  2804.                   IF (PTYP .EQ. 1) THEN
  2805.                      CALL PUTSTR(FD,I2)
  2806.                   ELSE
  2807.                      CALL STRCPY(I2,STRNG(OPTR))
  2808.                      OPTR = OPTR + SLEN(I2)
  2809.                   ENDIF
  2810.                ELSE IF (IPTR .EQ. 3) THEN
  2811.                   IF (PTYP .EQ. 1) THEN
  2812.                      CALL PUTSTR(FD,I3)
  2813.                   ELSE
  2814.                      CALL STRCPY(I3,STRNG(OPTR))
  2815.                      OPTR = OPTR + SLEN(I3)
  2816.                   ENDIF
  2817.                ELSE
  2818.                   IF (PTYP .EQ. 1) THEN
  2819.                      CALL PUTSTR(FD,I4)
  2820.                   ELSE
  2821.                      CALL STRCPY(I4,STRNG(OPTR))
  2822.                      OPTR = OPTR + SLEN(I4)
  2823.                   ENDIF
  2824.                ENDIF
  2825.                IPTR = IPTR + 1
  2826.  
  2827. *           IS IT A FIELD WIDTH SPECIFIER?
  2828.  
  2829.             ELSE IF (CH .GE. '0' .AND. CH .LE. '9') THEN
  2830.                SPTR = 0
  2831. 30             SPTR = SPTR + 1
  2832.                STR(SPTR) = ASC(CH)
  2833.                FPTR = FPTR + 1
  2834.                CH = FMT(FPTR:FPTR)
  2835.                IF (CH .GE. '0' .AND. CH .LE. '9') GO TO 30
  2836.                STR(SPTR+1) = 0
  2837.                INTWDTH = CTOI(STR)
  2838.                GO TO 20
  2839.  
  2840. *           UNKNOWN CONVERSION SO OUTPUT THE @ AND CONVERSION CHAR
  2841.  
  2842.             ELSE
  2843.                IF (PTYP .EQ. 1) THEN
  2844.                   CALL PUTC(ASC('@'),FD)
  2845.                   CALL PUTC(ASC(CH),FD)
  2846.                ELSE
  2847.                   STRNG(OPTR) = ASC('@')
  2848.                   STRNG(OPTR+1) = ASC(CH)
  2849.                   OPTR = OPTR + 2
  2850.                ENDIF
  2851.          ENDIF
  2852.          ENDIF
  2853.          FPTR = FPTR + 1
  2854.          GO TO 10
  2855.       ENDIF
  2856.       IF (PTYP .EQ. 2) STRNG(OPTR) = 0
  2857.  
  2858.  
  2859.       RETURN
  2860.       END
  2861.       SUBROUTINE DPC2AS(DSTR,ASTR,NWORDS)
  2862.  
  2863. ***   DPC2AS - CONVERT A DPC CHARACTER STRING TO UPPERCASE ASCII.
  2864. *
  2865. *     TRANSLATE STRING OF DISPLAY CODE CHARACTERS TO UPPERCASE ASCII.
  2866. *     STRING IS NWORDS CHARACTERS (WORDS) LONG, WITH A ZERO TERMINATION
  2867. *     AT NWORDS+1.
  2868.  
  2869.       IMPLICIT INTEGER (A-Z)
  2870.       PARAMETER (COMLIS = 0)
  2871.  
  2872. *CALL COMCKER
  2873.  
  2874.       CHARACTER*(*) DSTR
  2875.       BOOLEAN ASTR(*)
  2876.  
  2877.  
  2878.       DO 1 I=1,NWORDS
  2879.          ASTR(I) = UASCII((ICHAR(DSTR(I:I))))
  2880.     1    CONTINUE
  2881.  
  2882. *     SET ASCII END-OF-STRING-BUFFER
  2883.  
  2884.       ASTR(NWORDS+1) = 0
  2885.  
  2886.  
  2887.       RETURN
  2888.       END
  2889.       SUBROUTINE DPLXCMD
  2890.  
  2891. ***   DPLXCMD - PERFORM A SET DUPLEX XXXX COMMAND
  2892. *
  2893.  
  2894.       IMPLICIT INTEGER (A-Z)
  2895.       PARAMETER (COMLIS = 0)
  2896.  
  2897. *CALL COMCKER
  2898.  
  2899.       LOGICAL CONFIRM
  2900.       PARAMETER (TSIZE=2)
  2901.       CHARACTER*10 DUPTYP(TSIZE)
  2902.       DATA DUPTYP / 'FULL', 'HALF' /
  2903.  
  2904.  
  2905. *     MATCH THE PARAMETER
  2906.  
  2907.       INDX = MATCH(DUPTYP,TSIZE,.FALSE.)
  2908.       IF (INDX .LE. 0) RETURN
  2909.       IF (.NOT. CONFIRM(CMDFD)) RETURN
  2910.  
  2911. *     TAKE THE APPROPRIATE ACTION
  2912.  
  2913.       GO TO (10, 20), INDX
  2914.  
  2915. *     SET FULL DUPLEX
  2916.  
  2917.  10   CALL STTY('DUPLEX',FULLDUP)
  2918.       INITDUP = FULLDUP
  2919.       RETURN
  2920.  
  2921. *     SET HALF DUPLEX
  2922.  
  2923.  20   CALL STTY('DUPLEX',HALFDUP)
  2924.       INITDUP = HALFDUP
  2925.       RETURN
  2926.  
  2927.  
  2928.       END
  2929.           IDENT  EXE
  2930.           ENTRY  EXE
  2931.           B1=1
  2932.           TITLE  EXE - WRITE AND BEGIN A CCL PROC.
  2933.           COMMENT EXE - WRITE AND BEGIN A CCL PROC.
  2934.  EXE      SPACE  4,10
  2935. ***       EXE - WRITE AND BEGIN A CCL PROC.
  2936. *
  2937. *         ENTRY  (X1) = ADDRESS OF *C* FORMAT NOS COMMAND.
  2938. *
  2939. *         EXIT   NONE.
  2940.  
  2941.  EXE      SUBR               ENTRY
  2942.           SB1    1
  2943.           WRITEC ZZZZKCC,X1
  2944.           WRITEC ZZZZKCC,(=C*$REVERT,EX.KERMIT.*)
  2945.           WRITEC ZZZZKCC,(=C*$EXIT.*)
  2946.           WRITEC ZZZZKCC,(=C*$REVERT,EX.KERMIT.*)
  2947.           WRITER ZZZZKCC,R
  2948.           EXCST  (=C*$BEGIN,,ZZZZKCC.*)
  2949.  
  2950. *         FET AND BUFFER
  2951.  ZZZZKCC  FILEB  BUF,101B
  2952.  BUF      EQU    *
  2953.           ORG    ZZZZKCC+2
  2954.           VFD    42/0,18/CEND
  2955.           ORG    BUF
  2956.           DATA   C*.PROC,X.*
  2957.           DATA   C*$RETURN,ZZZZKCC.*
  2958.  CEND     EQU    *
  2959.           BSS    101B-CEND+BUF
  2960.  
  2961.           END
  2962.       SUBROUTINE EXPSTR(ISTR, LEN, OSTR)
  2963.  
  2964. ***   EXPSTR - EXPAND STRING
  2965. *
  2966. *     EXPSTR EXPANDS AN INPUT STRING, DUPLICATING REPEAT-PREFIXED
  2967. *     CHARACTERS AND REMOVING CONTROL-QUOTE CHARACTERS AS REQUIRED.
  2968. *     THIS ROUTINE DOESN'T HANDLE 8TH BIT QUOTED CONVERSIONS.
  2969. *
  2970. *     ENTRY ISTR - INPUT STRING
  2971. *           LEN  - INPUT STRING LENGTH
  2972. *           OSTR - OUTPUT STRING (WILL BE ZERO-TERMINATED)
  2973. *
  2974. *     NOTE THAT IF THERE IS NO REPEAT PREFIXING, REPCT = 0, BUT SINCE CH
  2975. *     CAN NEVER BE ZERO, EVERYTHING SHOULD BE OK.
  2976.  
  2977.       IMPLICIT INTEGER (A-Z)
  2978.       PARAMETER (COMLIS = 0)
  2979.  
  2980.       INTEGER ISTR(*), OSTR(*)
  2981.  
  2982. *CALL COMCKER
  2983.  
  2984. *CALL,COMXKER
  2985.  
  2986.       I1 = 1
  2987.       I2 = 1
  2988.  10   CH = ISTR(I1)
  2989.       IF((CH.EQ.REPCH) .AND. (CH.NE.0) .AND. (I1+2.LE.LEN)) THEN
  2990.          CH = ISTR(I1+2)
  2991.          DO 20 I3 = 1, UNCHAR(ISTR(I1+1))
  2992.          OSTR(I2) = CH
  2993.  20      I2 = I2 + 1
  2994.          I1 = I1 + 2
  2995.       ELSE IF(CH .EQ. SCQUOTE) THEN
  2996.          I1 = I1 + 1
  2997.          OSTR(I2) = ISTR(I1)
  2998.          I2 = I2 + 1
  2999.       ELSE
  3000.          OSTR(I2) = CH
  3001.          I2 = I2 + 1
  3002.       ENDIF
  3003.       I1 = I1 + 1
  3004.       IF(I1 .LE. LEN) GOTO 10
  3005.  
  3006.       OSTR(I2) = 0
  3007.       RETURN
  3008.       END
  3009.       SUBROUTINE FCLOSE(FD)
  3010.  
  3011. ***   FCLOSE - REMOVE AN FD FROM THE ACTIVE LIST.
  3012. *
  3013. *     FCLOSE WILL REMOVE THE FD FROM THE ACTIVE LIST FOR
  3014. *     ALLOCATION AT A LATER DATE.
  3015.  
  3016.       IMPLICIT INTEGER (A-Z)
  3017.       PARAMETER (COMLIS = 0)
  3018.  
  3019. *CALL COMCKER
  3020.  
  3021.  
  3022.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  3023.          CALL DISPLA(' FCLOSE - INVALID FD ',FD)
  3024.          CALL ABORT
  3025.       ELSE IF (FMODE(FD) .EQ. 0) THEN
  3026.          CALL DISPLA(' FCLOSE - FD NOT OPEN.',FD)
  3027.          RETURN
  3028.       ENDIF
  3029.  
  3030. *     FORCE EMPTYING OF THE BUFFER
  3031.  
  3032.       CALL FFLUSH(FD)
  3033.  
  3034. *     WRITE A FILE MARK
  3035.  
  3036.       IF(FMODE(FD) .EQ. WR .AND. .NOT. CTDEV(FD)) THEN
  3037.          CALL WRITER(FETS(0,FD),1)
  3038.       ENDIF
  3039.  
  3040.       FMODE(FD) = CLOSED
  3041.  
  3042.  
  3043.       RETURN
  3044.       END
  3045.       SUBROUTINE FFLUSH(FD)
  3046.  
  3047. ***   FFLUSH - FLUSH AN I/O BUFFER.
  3048. *
  3049. *     FFLUSH WILL FLUSH THE ASCII STRING BUFFER FOR A PARTICULAR
  3050. *     FILE DESCRIPTOR.
  3051.  
  3052.       IMPLICIT INTEGER (A-Z)
  3053.       PARAMETER (COMLIS = 0)
  3054.  
  3055. *                               #    E    O    R   \N
  3056.       PARAMETER (EORLINE = O"0043 0105 0117 0122 0000")
  3057.  
  3058. *                               #    E    O    F   \N
  3059.       PARAMETER (EOFLINE = O"0043 0105 0117 0106 0000")
  3060.  
  3061. *CALL COMCKER
  3062.  
  3063.       PARAMETER (FIRST = 1, IN = 2, OUT = 3, LIMIT = 4)
  3064.  
  3065.  
  3066. *     IS THE FD VALID?
  3067.  
  3068.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  3069.          CALL DISPLA(' FFLUSH - INVALID FILE DESCRIPTOR',FD)
  3070.          CALL ABORT
  3071.       ELSE IF (FMODE(FD) .EQ. 0) THEN
  3072.          CALL DISPLA(' FFLUSH - FILE DESCRIPTOR NOT OPEN',FD)
  3073.          CALL ABORT
  3074.       ENDIF
  3075.  
  3076. *     IF FD WAS OPENED FOR WRITE FLUSH TO THE FILE
  3077.  
  3078.       IF (FMODE(FD) .EQ. WR) THEN
  3079.          IF (FCSET(FD) .EQ. CSBIN) THEN
  3080.             CALL WRITEW(FETS(0,FD),FCHBUF(1,FD),FNWDS(FD),STATUS)
  3081.          ELSE IF (CTDEV(FD)) THEN
  3082.             IF (FCSET(FD) .EQ. CSDSP .OR. FCSET(FD) .EQ. CS612) THEN
  3083.                CALL A8SX12(FCHBUF(1,FD),FNWDS(FD))
  3084.                FNWDS(FD) = FINDEOL(FCHBUF(1,FD),FNWDS(FD),.FALSE.)
  3085.             ENDIF
  3086.             CALL WRITEW(FETS(0,FD),FCHBUF(1,FD),FNWDS(FD),STATUS)
  3087.  
  3088. *           ENSURE ZERO EOL BYTE
  3089.  
  3090.             IF((FCHBUF(FNWDS(FD),FD).AND.O"7777").NE.0) THEN
  3091.                CALL WRITEW(FETS(0,FD), 0, 1, STATUS)
  3092.             ENDIF
  3093.             CALL WRITE(FETS(0,FD), 0)
  3094.          ELSE
  3095.             IF (FCHBUF(1,FD) .EQ. EORLINE) THEN
  3096.                CALL WRITER(FETS(0,FD),1)
  3097.             ELSE IF (FCHBUF(1,FD) .EQ. EOFLINE) THEN
  3098.                CALL WRITEF(FETS(0,FD),1)
  3099.             ELSE
  3100.                IF (FCSET(FD) .EQ. CSDSP) THEN
  3101.                   CALL A8DPC(FCHBUF(1,FD),FNWDS(FD))
  3102.                   FNWDS(FD) = FINDEOL(FCHBUF(1,FD),FNWDS(FD),.FALSE.)
  3103.                ELSE IF (FCSET(FD) .EQ. CS612) THEN
  3104.                   CALL A8SX12(FCHBUF(1,FD),FNWDS(FD))
  3105.                   FNWDS(FD) = FINDEOL(FCHBUF(1,FD),FNWDS(FD),.FALSE.)
  3106.                ENDIF
  3107.                CALL WRITEW(FETS(0,FD),FCHBUF(1,FD),FNWDS(FD),STATUS)
  3108.             ENDIF
  3109.          ENDIF
  3110.  
  3111. *     IF FD WAS OPENED FOR READ CLEAR THE BUFFERS
  3112.  
  3113.       ELSE
  3114.          CALL RECALL(FETS(0,FD))
  3115.          FETS(IN,FD) = FETS(OUT,FD) = AND(FETS(FIRST,FD),O"777777")
  3116.          FUNGTCH(FD) = EOF
  3117.  
  3118.       ENDIF
  3119.  
  3120. *     RESET THE BUFFER POINTERS
  3121.  
  3122.       FWPTR(FD) = 1
  3123.       FNWDS(FD) = 0
  3124.       FWSHFT(FD) = 0
  3125.  
  3126.  
  3127.       RETURN
  3128.       END
  3129.       SUBROUTINE FILCHK(FN)
  3130.  
  3131. ***   FILCHK - CHECK AND FIX FILENAME VALIDITY.
  3132. *
  3133. *     CHECK VALIDITY OF FILENAME.  INVALID CHARACTERS ARE DROPPED.
  3134. *     IF A PERIOD IS FOUND (FILENAME.EXT), KEEP PART OF THE FILENAME
  3135. *     AND PART OF THE EXTENSION (NORMALLY 4 AND 3 CHARACTERS,
  3136. *     RESPECTIVELY).  USE UP TO 7 CHARACTERS OF THE INPUT NAME.
  3137. *     IF THERE IS NO VALID FILENAME (NO CHARACTERS WERE ALPHANUMERIC),
  3138. *     THEN RETURN THE NAME 'KERMDAT'.
  3139.  
  3140.       IMPLICIT INTEGER (A-Z)
  3141.       PARAMETER (COMLIS = 0)
  3142.  
  3143. *CALL COMCKER
  3144.  
  3145.       CHARACTER CH*1
  3146.       CHARACTER FN*(*)
  3147.  
  3148.       LENGTH = LEN(FN)
  3149.       L1 = 0
  3150.       EXTP = 0
  3151.  
  3152. *     REMOVE INVALID CHARACTERS, DETERMINE LENGTH OF STRING
  3153. *     AND START OF EXTENSION.
  3154.  
  3155.       DO 10 I1 = 1, LENGTH
  3156.       CH = FN(I1:I1)
  3157.       IF((CH.GE.'A'.AND.CH.LE.'Z') .OR. (CH.GE.'0'.AND.CH.LE.'9')) THEN
  3158.          L1 = L1 + 1
  3159.          FN(L1:L1) = CH
  3160.       ELSE IF((CH.EQ.'.') .AND. (EXTP.EQ.0)) THEN
  3161.          EXTP = L1 + 1
  3162.       ENDIF
  3163. 10    CONTINUE
  3164.  
  3165. *     IF STRING CONTAINS ALL ILLEGAL CHARACTERS, USE DEFAULT FILE NAME.
  3166. *     IF EMPTY EXTENSION OR NO EXTENSION, TRUNCATE STRING AT 7.
  3167. *     IF STRING > 7 CHARACTERS, TRUNCATE EXTENSION TO 3 CHARACTERS
  3168. *        (UNLESS THE FILENAME PART IS SHORT) AND THE ENTIRE STRING
  3169. *        TO 7, MOVE THE EXTENSION DOWN.
  3170.  
  3171.       IF(L1 .EQ. 0) THEN
  3172.          FN = 'KERMDAT'
  3173.          L1 = 7
  3174.       ELSE IF((EXTP.EQ.0) .OR. (EXTP.GT.L1)) THEN
  3175.          L1 = MIN0(L1, 7)
  3176.       ELSE
  3177. *        (IF FILENAME > 4 CHARACTERS, RETAIN UP TO 3 CHARACTERS OF THE
  3178. *         EXTENSION; ELSE, KEEP AS MANY AS POSSIBLE.)
  3179.          MAXEL = MAX0(3,7-(EXTP-1))
  3180.          L1 = MIN0(L1, EXTP+MAXEL-1)
  3181.          IF(L1 .GT. 7) THEN
  3182.             REMOVE = L1 - 7
  3183.             DO 20 I1 = EXTP, L1
  3184.             CH = FN(I1:I1)
  3185.             FN(I1-REMOVE:I1-REMOVE) = CH
  3186. 20          CONTINUE
  3187.             L1 = 7
  3188.          ENDIF
  3189.       ENDIF
  3190.       DO 30 I1 = L1+1, LENGTH
  3191.       FN(I1:I1) = ' '
  3192. 30    CONTINUE
  3193.       RETURN
  3194.       END
  3195.           IDENT  FILECS
  3196.           ENTRY  FILECS
  3197.           B1=1
  3198.           TITLE   FILECS - RETURN THE CHARACTER SET OF A CIO BUFFER
  3199.           COMMENT RETURN THE CHARACTER SET OF A CIO BUFFER
  3200.  FILECS   SPACE  4,10
  3201. ***       INTEGER FUNCTION FILECS(FET)
  3202. *
  3203. *         RETURN THE CHARACTER SET OF A CIO BUFFER.
  3204. *
  3205. *         ENTRY  (X1) = FWA OF FET OF FILE TO BE CHECKED.  THE CIRCULAR
  3206. *                       BUFFER SHOULD HAVE BEEN FILLED BY A PREVIOUS
  3207. *                       READ FUNCTION.
  3208. *
  3209. *         EXIT   (X6) = -1 IF THE BUFFER IS EMPTY.
  3210. *                     =  1 FOR DISPLAY CODE.
  3211. *                     =  2 FOR 8/12 ASCII.
  3212. *                     =  3 FOR 6/12 ASCII.
  3213. *
  3214. *         USES   X - 0, 1, 2, 3, 4, 5, 6.
  3215. *                A - 1, 2, 3, 4, 5.
  3216. *                B - 1, 2, 3, 4, 5, 6.
  3217. *
  3218. *
  3219. *         PAUL WELLS  82/11/12
  3220.  
  3221.  
  3222.  FILECS   SUBR               ENTRY/EXIT
  3223.           SB1    1
  3224.  
  3225.           SA1    X1+B1       (X1) = FET+1
  3226.           SB2    X1          (B2) = *FIRST*
  3227.           SA1    A1+B1
  3228.           SB3    X1          (B3) = *IN*
  3229.           SA1    A1+B1
  3230.           SB4    X1          (B4) = *OUT*
  3231.           SA1    A1+B1
  3232.           SB5    X1          (B5) = *LIMIT*
  3233.  
  3234.           MX0    0           CLEAR ASCII HIGH BITS ACCUMULATOR
  3235.           SX6    -B1         PRESET EMPTY BUFFER STATUS
  3236.           EQ     B3,B4,FILECSX  IF BUFFER EMPTY
  3237.  
  3238.           SA2    GCSA        (X2) = 8/12 MASK
  3239.           SA3    A2+B1       (X3) = CARETS
  3240.           SA4    A3+B1       (X4) = 6/12 MASK
  3241.           SX6    B1+         PRESET DISPLAY CODE STATUS
  3242.  
  3243.  GCS1     SA1    B4+         (X1) = WORD FROM BUFFER
  3244.           BX5    X2*X1       (X5) = HIGH BITS OF EACH BYTE
  3245.           BX0    X0+X5       ACCUMULATE HIGH BITS
  3246.  
  3247.           SB6    8           (B6) = 6/12 SHIFT COUNTER
  3248.  GCS2     BX5    X4*X1       (X5) = FIRST AND THIRD CHARACTERS
  3249.           BX5    X5-X3
  3250.           NZ     X5,GCS3     IF NOT TWO CARETS
  3251.           SX6    3           SET 6/12 STATUS
  3252.  GCS3     LX1    6           LOOK AT NEXT CHARACTER POSITION
  3253.           SB6    B6-B1       DECREMENT SHIFT COUNT
  3254.           NZ     B6,GCS2     LOOP ON THIS WORD
  3255.  
  3256.           SB4    B4+B1       ADVANCE BUFFER POINTER
  3257.           NE     B4,B5,GCS4  IF NO WRAP AROUND
  3258.           SB4    B2          WRAP
  3259.  GCS4     NE     B4,B3,GCS1  IF NOT END OF DATA
  3260.  
  3261.  
  3262. *         HERE WHEN THE TEST LOOP IS COMPLETE
  3263.           NZ     X0,FILECSX  RETURN IF NOT 8/12
  3264.           SX6    2           RETURN 8/12 STATUS
  3265.           EQ     FILECSX     RETURN
  3266.  
  3267.  
  3268. *         MASKS
  3269.  GCSA     DATA   74007400740074007400B
  3270.           DATA   76007600000000000000B
  3271.           DATA   77007700000000000000B
  3272.  
  3273.           END
  3274.       INTEGER FUNCTION FINDEOL(WSA,WSAL,ADDNEL)
  3275.  
  3276. ***   FINDEOL - FIND EOL BYTE IN WORKING BUFFER.
  3277. *
  3278. *     ENTRY   (WSA)    = LINE IMAGE.
  3279. *             (WSAL)   = LENGTH OF WSA.
  3280. *             (ADDNEL) = .TRUE. IF A NEL SHOULD BE APPENDED TO BUFFER.
  3281. *
  3282. *     EXIT    (FINDEOL) = LENGTH OF DATA LINE IN WORDS.
  3283.  
  3284.       IMPLICIT INTEGER (A-Z)
  3285.       PARAMETER (COMLIS = 0)
  3286.  
  3287. *CALL COMCKER
  3288.  
  3289.       BOOLEAN WSA(WSAL)
  3290.       LOGICAL ADDNEL
  3291.  
  3292.  
  3293. *     IF THE LINE LENGTH IS ZERO, RETURN ZERO LENGTH
  3294.  
  3295.       IF(WSAL .LE. 0) THEN
  3296.           FINDEOL = 0
  3297.           RETURN
  3298.       ENDIF
  3299.  
  3300. *     FIND ZERO BYTE EOL AND REPLACE WITH NEL IF REQUESTED
  3301.  
  3302.       DO 20 I = 1, WSAL
  3303.          IF (AND(WSA(I),O"7777") .EQ. 0) THEN
  3304.             IF (ADDNEL) THEN
  3305.                WSA(I) = OR(WSA(I),NEL)
  3306.             ENDIF
  3307.             FINDEOL = I
  3308.             RETURN
  3309.          ENDIF
  3310.  20   CONTINUE
  3311.  
  3312. *     NO EOL FOUND - REPLACE LAST BYTE WITH NEL
  3313.  
  3314.       IF(ADDNEL) WSA(WSAL) = OR(AND(WSA(WSAL),MASK(48)),NEL)
  3315.       FINDEOL = WSAL
  3316.  
  3317.  
  3318.       RETURN
  3319.       END
  3320.       INTEGER FUNCTION FOPEN(FN,MODE,CSET)
  3321.  
  3322. ***   FOPEN - OPEN A FILE FOR I/O.
  3323. *
  3324. *     FOPEN ASSIGNS A FILE DESCIPTOR (INTEGER INDEX) TO A FILE NAME.
  3325. *
  3326. *     ENTRY    (FN)   = FILE NAME.
  3327. *              (MODE) = FILE MODE.
  3328. *                     = *RD* FOR READ MODE.
  3329. *                     = *WR* FOR WRITE MODE.
  3330. *                     = *CREATE* FOR NEW FILE / WRITE MODE.
  3331. *              (CSET) = CHARACTER SET OF THE FILE.
  3332. *                     = *CSNONE* FOR NONE SPECIFIED (CHECK IT).
  3333. *                     = *CSDSP* FOR DISPLAY CODE.
  3334. *                     = *CS812* FOR 8/12 ASCII.
  3335. *                     = *CS612* FOR 6/12 ASCII.
  3336. *                     = *CSBIN* FOR BINARY (60 BIT).
  3337. *                     = *CSTXP* FOR INTERACTIVE TRANSPARENT.
  3338. *
  3339. *     EXIT     (FOPEN) = FILE DESCRIPTOR OR ERROR CODE.
  3340.  
  3341.       IMPLICIT INTEGER (A-Z)
  3342.       PARAMETER (COMLIS = 0)
  3343.  
  3344. *CALL COMCKER
  3345.  
  3346.       CHARACTER*10 FN
  3347.       LOGICAL CFE
  3348.  
  3349.  
  3350. *     CHECK FOR VALID PARAMETERS
  3351.  
  3352.       IF (MODE .LT. RD .OR. MODE .GT. CREATE) THEN
  3353.          CALL DISPLA(' FOPEN - INVALID MODE ',MODE)
  3354.          CALL ABORT
  3355.       ENDIF
  3356.  
  3357. *     FIND THE NEXT UNUSED ENTRY
  3358.  
  3359.       DO 100 I = 1, MAXFILE
  3360.  
  3361. *        SET THE FILE NAME, DEVICE TYPE, AND MODE
  3362.  
  3363.          IF (FMODE(I) .EQ. CLOSED) THEN
  3364.             IF (FN .EQ. 'STDIN') THEN
  3365.                FNAME(I) = 'INPUT'
  3366.                CTDEV(I) = .TRUE.
  3367.             ELSE IF (FN .EQ. 'STDOUT') THEN
  3368.                FNAME(I) = 'OUTPUT'
  3369.                CTDEV(I) = .TRUE.
  3370.             ELSE
  3371.                FNAME(I) = FN
  3372.                CTDEV(I) = .FALSE.
  3373.             ENDIF
  3374.             IF (MODE .EQ. CREATE) THEN
  3375.                IF (.NOT.CTDEV(I) .AND. CFE(FNAME(I))) THEN
  3376.                   FMODE(I) = CLOSED
  3377.                   FOPEN = ERROR
  3378.                   RETURN
  3379.                ENDIF
  3380.                FMODE(I) = WR
  3381.             ELSE
  3382.                FMODE(I) = MODE
  3383.             ENDIF
  3384.  
  3385. *           INITIALIZE THE FILE
  3386.  
  3387.             CALL MAKEFET(FNAME(I),FETS(0,I),FETL,CIOBUFF(1,I),CIOBUFL)
  3388.             FCSET(I) = CSET
  3389.             IF (.NOT.CTDEV(I)) THEN
  3390.                CALL NODROP(FETS(0,I))
  3391.                CALL REWIND(FETS(0,I),1)
  3392.                IF (FMODE(I) .EQ. RD) THEN
  3393.                   CALL READ(FETS(0,I),1)
  3394.                   IF (CSET .EQ. CSNONE) THEN
  3395.                      FCSET(I) = MAX(FILECS(FETS(0,I)),CSDSP)
  3396.                   ENDIF
  3397.                ELSE
  3398.                   IF (CSET .EQ. CSNONE) THEN
  3399.                      FCSET(I) = CS612
  3400.                   ENDIF
  3401.                ENDIF
  3402.             ENDIF
  3403.  
  3404. *           INITIALIZE THE BUFFER POINTERS
  3405.  
  3406.             FWPTR(I) = 1
  3407.             FNWDS(I) = 0
  3408.             FWSHFT(I) = 0
  3409.             FEOF(I) = .FALSE.
  3410.  
  3411.             FOPEN = I
  3412.             RETURN
  3413.  
  3414. *        IF TABLE ENTRY FILE NAME MATCHES FN
  3415.  
  3416.          ELSE IF (FNAME(I) .EQ. FN) THEN
  3417.             CALL REMARK(' FOPEN - FILE ' // FN // ' ALREADY OPEN.')
  3418.             CALL ABORT
  3419.  
  3420.          ENDIF
  3421. 100   CONTINUE
  3422.  
  3423. *     NO UNUSED ENTRY FOUND
  3424.  
  3425.       CALL REMARK(' FOPEN - TOO MANY FILES OPEN.')
  3426.       CALL ABORT
  3427.  
  3428.       END
  3429.       SUBROUTINE FPRINTF(FD,FMT,I1,I2,I3,I4)
  3430.  
  3431. ***   FPRINTF - POOR ATTEMPT AT FORMATTED ASCII OUTPUT.
  3432. *
  3433. *     CONVERSION IS SIMILAR TO FPRINTF USED IN C.  SUPPORTED
  3434. *     CONVERSIONS ARE @D (INTEGER), @C (ASCII CHARACTER), @S (ASCII
  3435. *     STRING BUFFER).  A \N WILL MAP TO A NEWLINE, A \T WILL
  3436. *     WILL MAP TO A TAB, A \0 WILL TERMINATE THE FORMAT SCANNING.
  3437. *     A \ FOLLOWED BY ANY OTHER CHARACTER WILL CAUSE THAT CHARACTER
  3438. *     TO BE OUTPUT.  THE DEFAULT OUTPUT CASE WILL BE LOWERCASE.
  3439. *     A ^ FOLLOWED BY A LETTER WILL CAUSE THAT CHARACTER TO BE OUTPUT
  3440. *     AS UPPERCASE.  A @D CONVERSION MAY NOW SPECIFY A MINIMUM FIELD
  3441. *     WIDTH AS @<N>D (I.E. @10D) IN WHICH THE NUMBER WILL BE BLANK
  3442. *     PADDED TO THE RIGHT TO USE UP <N> CHARACTERS.
  3443.  
  3444.       IMPLICIT INTEGER (A-Z)
  3445.       PARAMETER (COMLIS = 0)
  3446.  
  3447. *CALL COMCKER
  3448.  
  3449.       CHARACTER*(*) FMT
  3450.  
  3451.  
  3452. *     IS THE FD VALID?
  3453.  
  3454.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  3455.          CALL DISPLA(' FPRINTF - INVALID FD ',FD)
  3456.          CALL ABORT
  3457.       ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
  3458.          CALL DISPLA(' FPRINTF - FD NOT OPEN.',FD)
  3459.          RETURN
  3460.       ENDIF
  3461.  
  3462. *     IS IT OK TO WRITE ON THIS STREAM?
  3463.  
  3464.       IF ((FMODE(FD).AND.WR) .NE. WR) THEN
  3465.          CALL DISPLA(' FPRINTF - WRITE ON READ-ONLY FILE ',FD)
  3466.          CALL ABORT
  3467.       ENDIF
  3468.  
  3469. *     NOW CALL THE REAL FPRINTF WORKHORSE
  3470.  
  3471.       CALL DOPRNT(FD,0,1,FMT,I1,I2,I3,I4)
  3472.  
  3473.  
  3474.       RETURN
  3475.       END
  3476.       SUBROUTINE FREAD(FD,BUF,NWD)
  3477.  
  3478. ***   FREAD - READ SOME WORDS FROM A FILE.
  3479. *
  3480.  
  3481.       IMPLICIT INTEGER (A-Z)
  3482.       PARAMETER (COMLIS = 0)
  3483.  
  3484. *CALL COMCKER
  3485.  
  3486.       BOOLEAN BUF(NWD)
  3487.  
  3488.  
  3489. *     IS THE FD VALID?
  3490.  
  3491.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  3492.          CALL DISPLA(' FREAD - INVALID FILE DESCRIPTOR',FD)
  3493.          CALL ABORT
  3494.       ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
  3495.          CALL DISPLA(' FREAD - FILE DESCRIPTOR NOT OPEN',FD)
  3496.          CALL ABORT
  3497.       ENDIF
  3498.  
  3499. *     CHECK IF OK TO READ
  3500.  
  3501.       IF ((FMODE(FD).AND.RD) .NE. RD) THEN
  3502.          CALL DISPLA(' FREAD - READ ON WRITE-ONLY FILE ',FD)
  3503.          CALL ABORT
  3504.       ENDIF
  3505.  
  3506. *     TRANSFER WORDS FROM THE FILE
  3507.  
  3508.       CALL READW(FETS(0,FD),BUF,NWD,STATUS)
  3509.  
  3510.  
  3511.       RETURN
  3512.       END
  3513.       SUBROUTINE FWRITE(FD,BUF,NWD)
  3514.  
  3515. ***   FWRITE - WRITE SOME WORDS TO A FILE.
  3516. *
  3517.  
  3518.       IMPLICIT INTEGER (A-Z)
  3519.       PARAMETER (COMLIS = 0)
  3520.  
  3521. *CALL COMCKER
  3522.  
  3523.       BOOLEAN BUF(NWD)
  3524.  
  3525.  
  3526. *     IS THE FD VALID?
  3527.  
  3528.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  3529.          CALL DISPLA(' FWRITE - INVALID FD ',FD)
  3530.          CALL ABORT
  3531.       ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
  3532.          CALL DISPLA(' FWRITE - FD NOT OPEN.',FD)
  3533.          RETURN
  3534.       ENDIF
  3535.  
  3536. *     IS IT OK TO WRITE ON THIS STREAM?
  3537.  
  3538.       IF ((FMODE(FD).AND.WR) .NE. WR) THEN
  3539.          CALL DISPLA(' FWRITE - WRITE ON READ-ONLY FILE ',FD)
  3540.          CALL ABORT
  3541.       ENDIF
  3542.  
  3543. *     WRITE THE WORDS TO THE FILE
  3544.  
  3545.       CALL WRITEW(FETS(0,FD),BUF,NWD,STATUS)
  3546.  
  3547.  
  3548.       RETURN
  3549.       END
  3550.       INTEGER FUNCTION GETC(FD,CH)
  3551.  
  3552. ***   GETC - RETURN NEXT CHARACTER FROM THE INPUT STREAM.
  3553. *
  3554. *     GETC WILL RETURN THE NEXT BYTE READ FROM THE FILE DESCRIPTOR FD.
  3555. *     EOF (-1) IS RETURNED WHEN EOF IS READ ON A DISK FILE.  CONNECTED
  3556. *     FILES NEVER RETURN EOF.
  3557. *
  3558. *     ZERO BYTES IN NON-BINARY FILES ARE IGNORED.
  3559.  
  3560.       IMPLICIT INTEGER (A-Z)
  3561.       PARAMETER (COMLIS = 0)
  3562.  
  3563. *CALL COMCKER
  3564.  
  3565.  
  3566. *     IS THE FD VALID?
  3567.  
  3568.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  3569.          CALL DISPLA(' GETC - INVALID FILE DESCRIPTOR',FD)
  3570.          CALL ABORT
  3571.       ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
  3572.          CALL DISPLA(' GETC - FILE DESCRIPTOR NOT OPEN',FD)
  3573.          CALL ABORT
  3574.       ENDIF
  3575.  
  3576. *     CHECK IF OK TO READ
  3577.  
  3578.       IF ((FMODE(FD).AND.RD) .NE. RD) THEN
  3579.          CALL DISPLA(' GETC - READ ON WRITE-ONLY FILE ',FD)
  3580.          CALL ABORT
  3581.       ENDIF
  3582.  
  3583. *     CHECK FOR A PUSHED-BACK CHARACTER
  3584.  
  3585.       IF (FUNGTCH(FD) .NE. EOF) THEN
  3586.          GETC = CH = FUNGTCH(FD)
  3587.          FUNGTCH(FD) = EOF
  3588.          RETURN
  3589.       ENDIF
  3590.  
  3591. *     GET MORE DATA IF NEEDED
  3592.  
  3593.  10   IF (FWPTR(FD) .GT. FNWDS(FD)) THEN
  3594.          IF (FEOF(FD)) THEN
  3595.             GETC = CH = EOF
  3596.             RETURN
  3597.          ELSE
  3598.             FNWDS(FD) = GETREC(FD,FCHBUF(1,FD),MAXWD,FEOF(FD))
  3599.             FWPTR(FD) = 1
  3600.             IF (FCSET(FD) .EQ. CSBIN) THEN
  3601.                FWSHFT(FD) = 8
  3602.             ELSE IF (FCSET(FD) .EQ. CSTXP) THEN
  3603.                FWSHFT(FD) = 24
  3604.             ELSE
  3605.                FWSHFT(FD) = 12
  3606.             ENDIF
  3607.             GOTO 10
  3608.          ENDIF
  3609.       ENDIF
  3610.  
  3611. *     BREAK OUT THE NEXT BYTE FROM THE BUFFER
  3612.  
  3613.       IF (FCSET(FD) .EQ. CSBIN) THEN
  3614.          IF (FWSHFT(FD) .EQ. 64) THEN
  3615.             CH = OR( AND(SHIFT(FCHBUF(FWPTR(FD)+0,FD),4),Z"F0"),
  3616.      -               AND(SHIFT(FCHBUF(FWPTR(FD)+1,FD),4),Z"0F") )
  3617.             FWSHFT(FD) = 4+8
  3618.             FWPTR(FD) = FWPTR(FD)+1
  3619.          ELSE IF (FWSHFT(FD) .EQ. 60) THEN
  3620.             CH = AND(FCHBUF(FWPTR(FD),FD),Z"FF")
  3621.             FWSHFT(FD) = 8
  3622.             FWPTR(FD) = FWPTR(FD)+1
  3623.          ELSE
  3624.             CH = AND(SHIFT(FCHBUF(FWPTR(FD),FD),FWSHFT(FD)),Z"FF")
  3625.             FWSHFT(FD) = FWSHFT(FD)+8
  3626.          ENDIF
  3627.       ELSE
  3628.          IF (FWSHFT(FD) .EQ. 60) THEN
  3629.             CH = AND(FCHBUF(FWPTR(FD),FD),Z"FFF")
  3630.             FWSHFT(FD) = 12
  3631.             FWPTR(FD) = FWPTR(FD)+1
  3632.          ELSE
  3633.             CH = AND(SHIFT(FCHBUF(FWPTR(FD),FD),FWSHFT(FD)),Z"FFF")
  3634.             FWSHFT(FD) = FWSHFT(FD)+12
  3635.          ENDIF
  3636.          IF (CH .EQ. 0) THEN
  3637.             GOTO 10
  3638.          ELSE IF (CH .NE. NEL) THEN
  3639.             CH = AND(CH,Z"FF")
  3640.          ENDIF
  3641.       ENDIF
  3642.  
  3643.       GETC = CH
  3644.  
  3645.  
  3646.       RETURN
  3647.       END
  3648.       SUBROUTINE GETEMSG(STRNG)
  3649.  
  3650. ***   GETEMSG - GET AN ERROR MESSAGE STRING FOR THE CURRENT ERROR.
  3651. *
  3652.  
  3653.       IMPLICIT INTEGER (A-Z)
  3654.       PARAMETER (COMLIS = 0)
  3655.  
  3656. *CALL COMCKER
  3657.  
  3658.       INTEGER DIREC(8,2)
  3659.       INTEGER PACKNAM(9,0:6)
  3660.  
  3661.       DATA DIREC / 115, 101, 110, 100, 4*0,
  3662. *                    S    E    N    D
  3663.      +             114, 101,  99, 101, 105, 118, 101, 0 /
  3664. *                    R    E    C    E    I    V    E
  3665.  
  3666.       DATA PACKNAM / 85,  78,  75,  78,  79,  87,  78, 2*0,
  3667. *                     U    N    K    N    O    W    N
  3668.      +               73, 110, 105, 116, 5*0,
  3669. *                     I    N    I    T
  3670.      +               70, 105, 108, 101, 110,  97, 109, 101, 0,
  3671. *                     F    I    L    E    N    A    M    E
  3672.      +               68,  97, 116,  97, 5*0,
  3673. *                     D    A    T    A
  3674.      +               69,  79,  70, 6*0,
  3675. *                     E    O    F
  3676.      +               66, 114, 101,  97, 107, 4*0,
  3677. *                     B    R    E    A    K
  3678.      +               83, 101, 114, 118, 101, 114, 3*0 /
  3679. *                     S    E    R    V    E    R
  3680.  
  3681.  
  3682.       IF ((ABORTYP.AND.INITERR) .NE. 0) THEN
  3683.          PTYP = 1
  3684.       ELSE IF ((ABORTYP.AND.FILERR) .NE. 0) THEN
  3685.          PTYP = 2
  3686.       ELSE IF ((ABORTYP.AND.DATAERR) .NE. 0) THEN
  3687.          PTYP = 3
  3688.       ELSE IF ((ABORTYP.AND.EOFERR) .NE. 0) THEN
  3689.          PTYP = 4
  3690.       ELSE IF ((ABORTYP.AND.BRKERR) .NE. 0) THEN
  3691.          PTYP = 5
  3692.       ELSE IF ((ABORTYP.AND.SRVCMD) .NE. 0) THEN
  3693.          PTYP = 6
  3694.       ELSE
  3695.          PTYP = 0
  3696.       ENDIF
  3697.       DTYP = SHIFT(ABORTYP.AND.O"300",-6)
  3698.       IF ((ABORTYP.AND.TOOMANY) .NE. 0) THEN
  3699.          CALL SPRINTF(STRNG,'^CANNOT @S @S PACKET',DIREC(1,
  3700.      +      DTYP),PACKNAM(1,PTYP))
  3701.       ELSE IF ((ABORTYP.AND.INVALID) .NE. 0) THEN
  3702.          CALL SPRINTF(STRNG,
  3703.      +  '^RECEIVED AN INVALID PACKET WHILE TRYING TO @S @S PACKET',
  3704.      +  DIREC(1,DTYP),PACKNAM(1,PTYP))
  3705.       ELSE IF ((ABORTYP.AND.SEQERR) .NE. 0) THEN
  3706.          CALL SPRINTF(STRNG,
  3707.      +   '^PACKET SEQUENCE ERROR WHILE TRYING TO @S @S PACKET',
  3708.      +   DIREC(1,DTYP),PACKNAM(1,PTYP))
  3709.       ELSE IF ((ABORTYP.AND.LCLFILE) .NE. 0) THEN
  3710.          CALL SPRINTF(STRNG,'^FILE ALREADY EXISTS',0,0)
  3711.       ELSE IF ((ABORTYP.AND.NOTLCL) .NE. 0) THEN
  3712.          CALL SPRINTF(STRNG,'^FILE NOT FOUND',0,0)
  3713.       ELSE IF ((ABORTYP.AND.INVFN) .NE. 0) THEN
  3714.          CALL SPRINTF(STRNG,'^INVALID FILENAME',0,0)
  3715.       ELSE IF ((ABORTYP.AND.SRVCMD) .NE. 0) THEN
  3716.          CALL SPRINTF(STRNG,'^UNIMPLEMENTED SERVER COMMAND',0,0)
  3717.       ELSE IF ((ABORTYP.AND.INTRPT) .NE. 0) THEN
  3718.          CALL SPRINTF(STRNG, '^TRANSFER INTERRUPTED DURING @S.',
  3719.      +   DIREC(1, DTYP), 0, 0)
  3720.       ELSE IF ((ABORTYP.AND.MICERR) .NE. 0) THEN
  3721.          CALL STRCPY(MICMSG, STRNG)
  3722.       ENDIF
  3723.  
  3724.  
  3725.       RETURN
  3726.       END
  3727.       LOGICAL FUNCTION GETFILE(FTYPE)
  3728.  
  3729. ***   GETFILE - CHECK IF THE REQUESTED FILE (OR WILDCARD FILES)
  3730. *     EXIST SOMEWHERE IN THE SYSTEM.  IF FTYPE = B, CHECK FIRST FOR A
  3731. *     MATCH IN THE USER'S LOCAL FILES.  IF NOT FOUND, TRY THE USER'S PERM FILE
  3732. *     CATALOG.  IF FTYPE = L OR P, CHECK ONLY THE SPECIFIED LOCATION.
  3733. *
  3734. *     ENTRY    FTYPE = B TO ALLOW LOCAL OR PERMANENT FILE(S)
  3735. *                      L TO ALLOW LOCAL ONLY
  3736. *                      P TO ALLOW PERMANENT ONLY
  3737. *              WILDSET HAS BEEN CALLED W/ FILE NAME STRING.
  3738. *
  3739. *     EXIT     (GETFILE) = .TRUE. IF FILE HAS BEEN FOUND SOMEWHERE.
  3740. *              (FILESTR) HAS FIRST FILE NAME STRING.
  3741. *              (LOCFILE) = .TRUE. IF TRANSFER IS FROM LOCAL FILES,
  3742. *                          .FALSE. IF TRANSFER IF FROM PERM FILES.
  3743. *
  3744.  
  3745.       IMPLICIT INTEGER (A-Z)
  3746.       PARAMETER (COMLIS = 0)
  3747.  
  3748. *CALL COMCKER
  3749.  
  3750.  
  3751.  
  3752.       CHARACTER LFN*10
  3753.  
  3754. *     CHECK TO SEE IF WE CAN FIND A MATCHING FILE.  LOOK IN LOCAL FILE
  3755. *     LIST AND/OR THE PERMANENT FILE CATALOG.
  3756.  
  3757.       IF((FTYPE.EQ.L) .OR. (FTYPE.EQ.B)) THEN
  3758.          CALL GETLFNI
  3759.          CALL GETLFN(LFN)
  3760.          LOCFILE = (LFN .NE. ' ')
  3761.       ENDIF
  3762.       IF((FTYPE.EQ.P) .OR. ((FTYPE.EQ.B).AND..NOT.LOCFILE)) THEN
  3763.          CALL GETPFNI
  3764.          CALL GETPFN(LFN)
  3765.          LOCFILE = .FALSE.
  3766.       ENDIF
  3767.  
  3768.       IF(LFN.EQ.' ') THEN
  3769.          GETFILE = .FALSE.
  3770.          RETURN
  3771.       ELSE
  3772.          GETFILE = .TRUE.
  3773.          IF(.NOT.LOCFILE) THEN
  3774.             CALL GETPFIL(LFN)
  3775.          ENDIF
  3776.       ENDIF
  3777.  
  3778. *     MOVE ACTUAL FILE NAME OF FIRST FILE TO STRING
  3779.  
  3780.       CALL DPC2AS(LFN, FILESTR, INDEX(LFN,' ')-1)
  3781.       RETURN
  3782.       END
  3783.       SUBROUTINE GETFTY(STR, FTYPE)
  3784.  
  3785. ***   GETFTY - GET AND REMOVE FILE TYPE SPECIFIER FROM STRING.
  3786. *
  3787. *     CHECKS THE STRING, AND IF THERE IS A FILE TYPE SPECIFIER, REMOVE
  3788. *     IT FROM THE STRING AND RETURN THE VALUE OF THE SPECIFIER.  VALID
  3789. *     SPECIFIERS ARE: 
  3790. *        L: FOR LOCAL FILES ONLY
  3791. *        P: FOR PERMANENT FILES ONLY
  3792. *        B: FOR LOCAL OR PERMANENT FILES.
  3793. *     ANY OTHER FILE TYPE OR NONE IS RETURNED AS B
  3794. *
  3795. *     ENTRY STR   ASCII STRING ARRAY
  3796. *     EXIT  FTYPE L, P, OR B.
  3797. *
  3798.       IMPLICIT INTEGER (A-Z)
  3799.       PARAMETER (COMLIS = 0)
  3800.  
  3801. *CALL COMCKER
  3802.  
  3803.       DIMENSION STR(*)
  3804.  
  3805.       IF(STR(2) .EQ. COLON) THEN
  3806.          IF((STR(1).AND.O"137") .EQ. L) THEN
  3807.             FTYPE = L
  3808.          ELSE IF((STR(1).AND.O"137") .EQ. P) THEN
  3809.             FTYPE = P
  3810.          ELSE
  3811.             FTYPE = B
  3812.          ENDIF
  3813.          CALL STRCPY(STR(3), STR(1))
  3814.       ELSE
  3815.          FTYPE = B
  3816.       ENDIF
  3817.       RETURN
  3818.  
  3819.       END
  3820.       LOGICAL FUNCTION GETPFIL(LFN)
  3821.  
  3822. ***   GETPFIL - GET/ATTACH A PERMANENT FILE.
  3823. *
  3824. *     ENTRY    (LFN) = FILE NAME.
  3825. *
  3826. *     EXIT     (GETFILE) = .TRUE. IF FILE IS NOW LOCAL.
  3827.  
  3828.       IMPLICIT INTEGER (A-Z)
  3829.       PARAMETER (COMLIS = 0)
  3830.  
  3831. *CALL COMCKER
  3832.  
  3833.       CHARACTER*(*) LFN
  3834.       CALL PF('GET',LFN,LFN,'RC',REPLY,'NA',' ')
  3835.       IF (REPLY .NE. 0) CALL PF('ATTACH',LFN,LFN,'RC',REPLY,'NA',' ')
  3836.  
  3837.       GETPFIL = (REPLY .EQ. 0)
  3838.  
  3839.       RETURN
  3840.       END
  3841.       SUBROUTINE GETLFN(NAME)
  3842.  
  3843. ***   GETLFN - GET THE NAME OF NEXT LOCAL FILE IN THE JOB WHICH
  3844. *     MATCHES THE WILDCARD CRITERIA.
  3845. *
  3846. *     BE SURE TO CALL 'GETLFNI' AND 'WILDSET' FIRST!
  3847. *
  3848. *     CALL GETLFN(NAME)
  3849. *
  3850. *     ENTRY    GETLFNI AND WILDSET SHOULD HAVE BEEN CALLED
  3851. *     EXIT     NAME*7 CONTAINS THE NEXT LOCAL FILE, OR ' ' IF NO MORE
  3852. *              MATCHING FILES.
  3853. *
  3854.  
  3855.       CHARACTER NAME*(*)
  3856.       LOGICAL WILDMAT
  3857.  
  3858. 10    I = NEXTLF(1)
  3859.       IF(I .EQ. 0) THEN
  3860.          NAME = ' '
  3861.          RETURN
  3862.       ENDIF
  3863.       CALL MOVETOC(I, NAME)
  3864.       IF(.NOT.WILDMAT(NAME)) GOTO 10
  3865.       RETURN
  3866.  
  3867.       ENTRY GETLFNI
  3868.  
  3869. ***   GETLFNI - INITIALIZE FOR SEQUENCE OF 'GETLFN' CALLS.
  3870. *
  3871. *     HAS 'NEXTLF' RESET FOR BEGINNING OF LOCAL FILE LIST.
  3872. *
  3873.       I = NEXTLF(0)
  3874.       RETURN
  3875.       END
  3876.       SUBROUTINE GETNOW(MM,DD,YY,HR,MIN,SEC)
  3877.  
  3878. ***   GET THE CURRENT DATE AND TIME.
  3879. *
  3880.  
  3881.       IMPLICIT INTEGER (A-Z)
  3882.       PARAMETER (COMLIS = 0)
  3883.  
  3884. *CALL COMCKER
  3885.  
  3886.       CHARACTER*10 DATE, TIME, STRING
  3887.  
  3888.  
  3889.       STRING = DATE()
  3890.       OFFSET = ICHAR('0')
  3891.       YY = (ICHAR(STRING(2:2))-OFFSET)*10 + ICHAR(STRING(3:3))-OFFSET
  3892.       MM = (ICHAR(STRING(5:5))-OFFSET)*10 + ICHAR(STRING(6:6))-OFFSET
  3893.       DD = (ICHAR(STRING(8:8))-OFFSET)*10 + ICHAR(STRING(9:9))-OFFSET
  3894.       YY = YY + 1900
  3895.       STRING = TIME()
  3896.       HR  = (ICHAR(STRING(2:2))-OFFSET)*10 + ICHAR(STRING(3:3))-OFFSET
  3897.       MIN = (ICHAR(STRING(5:5))-OFFSET)*10 + ICHAR(STRING(6:6))-OFFSET
  3898.       SEC = (ICHAR(STRING(8:8))-OFFSET)*10 + ICHAR(STRING(9:9))-OFFSET
  3899.  
  3900.  
  3901.       RETURN
  3902.       END
  3903.       SUBROUTINE GETPFN(NAME)
  3904.  
  3905. ***   GETPFN - GET THE NAME OF NEXT PERM FILE IN THE CATALOG WHICH
  3906. *     MATCHES THE WILDCARD CRITERIA.
  3907. *
  3908. *     BE SURE TO CALL 'GETPFNI' AND 'WILDSET' FIRST!
  3909. *
  3910. *     CALL GETPFN(NAME)
  3911. *
  3912. *     ENTRY    GETPFNI AND WILDMAT SHOULD HAVE BEEN CALLED
  3913. *     EXIT     NAME*7 CONTAINS THE NEXT PERM FILE, OR ' ' IF NO MORE
  3914. *              MATCHING FILES.
  3915. *
  3916.  
  3917.       CHARACTER NAME*(*)
  3918.       LOGICAL WILDMAT
  3919.  
  3920. 10    I = NEXTPF(1)
  3921.       IF(I .EQ. 0) THEN
  3922.          NAME = ' '
  3923.          RETURN
  3924.       ENDIF
  3925.       CALL MOVETOC(I, NAME)
  3926.       IF(.NOT.WILDMAT(NAME)) GOTO 10
  3927.       RETURN
  3928.  
  3929.       ENTRY GETPFNI
  3930.  
  3931. ***   GETPFNI - INITIALIZE FOR SEQUENCE OF 'GETPFN' CALLS.
  3932. *
  3933. *     HAS 'NEXTPF' RESET FOR BEGINNING OF CATALOG.
  3934. *
  3935.       I = NEXTPF(0)
  3936.       RETURN
  3937.       END
  3938.       INTEGER FUNCTION GETREC(FD,WSA,WSAL,EOFFLAG)
  3939.  
  3940. ***   GETREC - READ A LINE FROM A FILE.
  3941. *
  3942. *     ENTRY   (FD) = FILE DESCRIPTOR.
  3943. *             (WSAL) = LENGTH OF WSA.
  3944. *
  3945. *     EXIT    (WSA) = DATA FROM FILE.
  3946. *             (GETREC) = NUMBER OF WORDS ACTUALLY PLACED IN WSA.
  3947. *             (EOFFLAG) = .TRUE. IF END OF FILE HIT.
  3948. *
  3949. *     NOTES: PERFORMS DISPLAY TO ASCII CONVERSION IF NEEDED.
  3950.  
  3951.       IMPLICIT INTEGER (A-Z)
  3952.       PARAMETER (COMLIS = 0)
  3953.  
  3954. *                               #    E    O    R   \N
  3955.       PARAMETER (EORLINE = O"0043 0105 0117 0122 3777")
  3956.  
  3957. *                               #    E    O    F   \N
  3958.       PARAMETER (EOFLINE = O"0043 0105 0117 0106 3777")
  3959.  
  3960. *CALL COMCKER
  3961.  
  3962.       BOOLEAN WSA(WSAL)
  3963.       BOOLEAN SWSA(MAXWD), STATUS
  3964.       LOGICAL EOFFLAG
  3965.  
  3966.  
  3967.       EOFFLAG = .FALSE.
  3968.       IF(CTDEV(FD)) THEN
  3969.  
  3970. *        PROCESS CONNECTED FILES.
  3971.  
  3972.          IF (RDELAY .GT. 0) CALL DELAY(RDELAY)
  3973.          CALL READ(FETS(0,FD),1)
  3974.          IF (FCSET(FD) .EQ. CSTXP) THEN
  3975.             CALL READC(FETS(0,FD),WSA,WSAL,STATUS)
  3976.             GETREC = FINDEOL(WSA,WSAL,.TRUE.)
  3977.          ELSE
  3978.             CALL READC(FETS(0,FD),SWSA,WSAL,STATUS)
  3979.             IF(STATUS .GE. 0) THEN
  3980.                CALL SX12A8(SWSA,WSA,WSAL,STATUS)
  3981.                GETREC = FINDEOL(WSA,WSAL,.TRUE.)
  3982.             ELSE
  3983.                WSA(1) = NEL
  3984.                GETREC = 1
  3985.             ENDIF
  3986.          ENDIF
  3987.  
  3988.       ELSE
  3989.  
  3990. *        PROCESS DISK FILES.
  3991.  
  3992.          IF(FCSET(FD) .EQ. CSBIN) THEN
  3993.             CALL READW(FETS(0,FD),WSA,WSAL,STATUS)
  3994.          ELSE IF (FCSET(FD) .EQ. CS812) THEN
  3995.             CALL READC(FETS(0,FD),WSA,WSAL,STATUS)
  3996.          ELSE
  3997.             CALL READC(FETS(0,FD),SWSA,MAXWD,STATUS)
  3998.             IF(STATUS .GE. 0) THEN
  3999.                IF(FCSET(FD) .EQ. CSDSP) THEN
  4000.                   CALL DPCA8(SWSA,WSA,WSAL,STATUS)
  4001.                ELSE
  4002.                   CALL SX12A8(SWSA,WSA,WSAL,STATUS)
  4003.                ENDIF
  4004.             ENDIF
  4005.          ENDIF
  4006.  
  4007.          IF (FCSET(FD) .EQ. CSBIN) THEN
  4008.             IF (STATUS .EQ. 0) THEN
  4009.                NWDS = WSAL
  4010.             ELSE IF (STATUS .GT. 0) THEN
  4011.                NWDS = STATUS-LOCF(WSA)
  4012.                CALL READ(FETS(0,FD),1)
  4013.             ELSE IF (STATUS .EQ. -1) THEN
  4014.                NWDS = 0
  4015.                CALL READ(FETS(0,FD),1)
  4016.             ELSE
  4017.                NWDS = 0
  4018.                EOFFLAG = .TRUE.
  4019.             ENDIF
  4020.          ELSE
  4021.             IF (STATUS .EQ. 0) THEN
  4022.                NWDS = FINDEOL(WSA,WSAL,.TRUE.)
  4023.             ELSE IF (STATUS .GT. 0) THEN
  4024.                NWDS = STATUS-LOCF(WSA)
  4025.                IF (NWDS .GT. 0) THEN
  4026.                   NWDS = FINDEOL(WSA,NWDS,.TRUE.)
  4027.                ENDIF
  4028.                CALL READ(FETS(0,FD),1)
  4029.                IF (AND(FETS(0,FD),O"7770") .EQ. O"0030") THEN
  4030.                   NWDS = NWDS+1
  4031.                   WSA(NWDS) = EOFLINE
  4032.                   CALL READ(FETS(0,FD),1)
  4033.                ELSE IF (AND(FETS(0,FD),O"7770") .EQ. O"1030") THEN
  4034.                   EOFFLAG = .TRUE.
  4035.                ELSE
  4036.                   NWDS = NWDS+1
  4037.                   WSA(NWDS) = EORLINE
  4038.                ENDIF
  4039.             ELSE IF (STATUS .EQ. -1) THEN
  4040.                CALL READ(FETS(0,FD),1)
  4041.                NWDS = 1
  4042.                WSA(NWDS) = EOFLINE
  4043.             ELSE
  4044.                NWDS = 0
  4045.                EOFFLAG = .TRUE.
  4046.             ENDIF
  4047.          ENDIF
  4048.          GETREC = NWDS
  4049.  
  4050.       ENDIF
  4051.  
  4052.  
  4053.       RETURN
  4054.       END
  4055.       INTEGER FUNCTION GETWORD(FD,STR,MAXLEN)
  4056.  
  4057. ***   GETWORD - GET A WORD FROM AN INPUT STREAM.
  4058. *
  4059. *     GETWORD CONSIDERS A WORD TO BE DELIMITED BY BLANKS.
  4060. *     IT WILL RETURN THE LENGTH OF THE WORD AS ITS VALUE.
  4061. *     NOTE THAT THE STRING IS TERMINATED BY A ZERO WORD AT LEN+1.
  4062. *
  4063.  
  4064.       IMPLICIT INTEGER (A-Z)
  4065.       PARAMETER (COMLIS = 0)
  4066.  
  4067. *CALL COMCKER
  4068.  
  4069.       INTEGER STR(*)
  4070.  
  4071.  
  4072.       LEN = 0
  4073.  
  4074. *     SKIP LEADING WHITE SPACES
  4075.  
  4076. 10    IF (GETC(FD,CH) .EQ. EOF) THEN
  4077.          GETWORD = EOF
  4078.          RETURN
  4079.       ELSE IF (CH .EQ. NEL) THEN
  4080.          GETWORD = 0
  4081.          RETURN
  4082.       ELSE IF (CH .EQ. BLANK .OR. CH .EQ. TAB) THEN
  4083.          GO TO 10
  4084.       ENDIF
  4085.  
  4086. *     ACCUMULATE CHARACTERS
  4087.  
  4088. 20    IF (LEN .LT. MAXLEN) THEN
  4089.          LEN = LEN + 1
  4090.          STR(LEN) = CH
  4091.       ENDIF
  4092.       CH = GETC(FD,CH)
  4093.       IF (CH .NE. EOF .AND. CH .NE. BLANK .AND. CH .NE. TAB .AND.
  4094.      +    CH .NE. NEL) GO TO 20
  4095.  
  4096. *     SAVE EOLS FOR NEXT GETWORD OR CONFIRM
  4097.  
  4098.       IF (CH .EQ. NEL) CALL UNGETC(FD,CH)
  4099.  
  4100.       STR(LEN+1) = 0
  4101.       GETWORD = LEN
  4102.  
  4103.  
  4104.       RETURN
  4105.       END
  4106.       INTEGER FUNCTION GTTY(MODE)
  4107.  
  4108. ***   GTTY - GET A TTY MODE.
  4109. *
  4110.  
  4111.       IMPLICIT INTEGER (A-Z)
  4112.       PARAMETER (COMLIS = 0)
  4113.  
  4114. *CALL COMCKER
  4115.  
  4116.       CHARACTER*(*) MODE
  4117.  
  4118.  
  4119.       IF (MODE .EQ. 'DUPLEX') THEN
  4120.          GTTY = DUPLEX
  4121.       ELSE
  4122.          CALL DISPLA(' GTTY - INVALID MODE ',BOOL(MODE))
  4123.          CALL ABORT
  4124.       ENDIF
  4125.  
  4126.  
  4127.       RETURN
  4128.       END
  4129.       INTEGER FUNCTION ITOS(INT,STR,MINWID)
  4130.  
  4131. ***   ITOS - CONVERT AN INTEGER TO STRING FORMAT.
  4132. *
  4133.  
  4134.       IMPLICIT INTEGER (A-Z)
  4135.       PARAMETER (COMLIS = 0)
  4136.  
  4137. *CALL COMCKER
  4138.  
  4139.       INTEGER STR(*)
  4140.  
  4141.  
  4142.       WIDTH = 0
  4143.       IF (INT .LT. 0) THEN
  4144.          WIDTH = 1
  4145.          STR(WIDTH) = ASC('-')
  4146.       ENDIF
  4147.       VAL = IABS(INT)
  4148.       ASCII0 = ASC('0')
  4149. 10    WIDTH = WIDTH + 1
  4150.       STR(WIDTH) = MOD(VAL,10) + ASCII0
  4151.       VAL = VAL / 10
  4152.       IF (VAL .NE. 0) GO TO 10
  4153.       STR(WIDTH+1) = 0
  4154.  
  4155. *     NOW REVERSE THE DIGITS
  4156.  
  4157.       IPTR = 1
  4158.       ENDPTR = WIDTH
  4159.       IF (STR(IPTR) .EQ. ASC('-')) IPTR = IPTR + 1
  4160. 20    IF (IPTR .LT. ENDPTR) THEN
  4161.          TCH = STR(IPTR)
  4162.          STR(IPTR) = STR(ENDPTR)
  4163.          STR(ENDPTR) = TCH
  4164.          IPTR = IPTR + 1
  4165.          ENDPTR = ENDPTR - 1
  4166.          GO TO 20
  4167.       ENDIF
  4168.       ITOS = WIDTH
  4169.  
  4170.  
  4171.       RETURN
  4172.       END
  4173.       SUBROUTINE LOGOUT
  4174.  
  4175. ***   LOGOUT - LOG OUT THE TERMINAL.
  4176. *
  4177. *     ENTRY    NONE.
  4178. *
  4179. *     EXIT     CONTROL BYTE SENT.
  4180.  
  4181.       IMPLICIT INTEGER (A-Z)
  4182.       PARAMETER (COMLIS = 0)
  4183.  
  4184. *CALL COMCKER
  4185.  
  4186.  
  4187.       IF (INITDUP .EQ. FULLDUP) THEN
  4188.          CALL STTY('RCV-OFF',FULLDUP)
  4189.       ELSE
  4190.          CALL STTY('RCV-OFF',HALFDUP)
  4191.       ENDIF
  4192.       FCHBUF(1,STDOUT) = O"0004 0000 0000 0000 0000"
  4193.       FNWDS(STDOUT) = 1
  4194.       CALL FFLUSH(STDOUT)
  4195.  
  4196.  
  4197.       RETURN
  4198.       END
  4199.           IDENT  MAKEFET
  4200.           ENTRY  MAKEFET
  4201.           SST
  4202.           SYSCOM B1
  4203.  MAKEFET  TITLE  MAKEFET - MAKE A FILE ENVIRONMENT TABLE.
  4204.           COMMENT MAKE A FILE ENVIRONMENT TABLE.
  4205.  MAKEFET  SPACE  4,10
  4206. **        MAKEFET - MAKE A FILE ENVIRONMENT TABLE.
  4207. *
  4208. *         CALL MAKEFET(LFN,FET,FETL,CIOBUF,CIOBUFL)
  4209. *
  4210. *         ENTRY  (LFN) = IS THE CHARACTER*7 FILE NAME.
  4211. *                (FET) = AN ARRAY TO RECEIVE THE FET.
  4212. *                (FETL) = LENGTH OF FET IN WORDS (MINIMUM OF 5).
  4213. *                (CIOBUF) = AN ARRAY TO BE USED AS THE CIO BUFFER.
  4214. *                (CIOBUFL) = THE LENGTH OF CIOBUF.
  4215. *
  4216. *         EXIT   FET BUILT.
  4217.  
  4218.  
  4219.  MAKEFET  SUBR               ENTRY/EXIT
  4220.           SB1    1
  4221.           SA2    A1+B1
  4222.           SB6    X2          (B6) = FET ADDRESS
  4223.           SA2    A2+B1
  4224.           SA3    X2          (X3) = FET LENGTH
  4225.           SA2    A2+B1
  4226.           SX6    X2          (X6) = FWA OF CIO BUFFER
  4227.           SA2    A2+B1
  4228.           SA2    X2          (X2) = BUFFER LENGTH
  4229.           IX7    X6+X2       (X7) = LIMIT POINTER
  4230.           SA6    B6+2        SET IN AND OUT
  4231.           SA6    A6+B1
  4232.           SA7    A6+B1       SET LIMIT
  4233.           SX7    X3-5        (X7) = FET LENGTH - 5
  4234.           SB7    X7
  4235.           LX7    18
  4236.           BX6    X6+X7       ADD (FET LENGTH - 5) TO FIRST
  4237.           SA6    B6+B1       SET FIRST
  4238.           MX7    0
  4239.  MAKEFET1 GT     B7,B0,MAKEFET2  IF NO MORE WORDS TO SET
  4240.           SA7    A7+B1
  4241.           SB7    B7-B1
  4242.           EQ     MAKEFET1    LOOP TILL DONE
  4243.  
  4244.  MAKEFET2 SB7    B1          LENGTH OF TRANSFER
  4245.           RJ     =XMFS>      MOVE LFN INTO FET
  4246.           SA1    B6-B1
  4247.           RJ     =XBTZ>      CONVERT BLANKS TO 00B
  4248.           SX1    B1          ADD COMPLETE BIT TO LFN
  4249.           BX6    X6+X1
  4250.           SA6    A1
  4251.           EQ     MAKEFETX    RETURN
  4252.  
  4253.           END
  4254.       INTEGER FUNCTION MATCH(TABLE,TABLEN,NELOK)
  4255.  
  4256. ***   MATCH - MATCH INPUT WITH A TABLE OF POSSIBILITIES.
  4257. *
  4258. *     TABLE SHOULD BE AN ARRAY OF CHARACTER STRINGS DEFINING WHAT
  4259. *     IS REASONABLE INPUT.  MATCH WILL READ INPUT AND RETURN THE
  4260. *     INDEX OF THE TABLE ENTRY THAT MATCHES OR "ERROR" IF A PROPER
  4261. *     MATCH COULDN'T BE MADE.  MATCHS WILL FAIL IF THE INPUT MATCH
  4262. *     IS AMBIGUOUS OR DOESN'T MATCH AT ALL.  A QUESTION MARK IN THE
  4263. *     INPUT WILL OUTPUT THE POSSIBLE MATCHES ACCORDING TO THE INPUT
  4264. *     PREVIOUSLY READ AND THEN RETURN AS IF NO MATCH WAS MADE.
  4265.  
  4266.       IMPLICIT INTEGER (A-Z)
  4267.       PARAMETER (COMLIS = 0)
  4268.  
  4269. *CALL COMCKER
  4270.  
  4271.       CHARACTER*(*) TABLE(TABLEN)
  4272.       LOGICAL NELOK
  4273.       CHARACTER*40 WORD
  4274.       INTEGER ASTR(41)
  4275.  
  4276.  
  4277. *     GET THE WORD TO MATCH
  4278.  
  4279.       LEN = GETWORD(CMDFD,ASTR,40)
  4280.       IF (LEN .EQ. 0) THEN
  4281.          MATCH = LEN
  4282.          IF (.NOT. NELOK) THEN
  4283.             MATCH = ERROR
  4284.             CALL FPRINTF(STDOUT,'?^NULL SWITCH OR KEYWORD GIVEN\N')
  4285.          ENDIF
  4286.          RETURN
  4287.       ELSE IF (LEN .EQ. EOF) THEN
  4288.          MATCH = EOF
  4289.          RETURN
  4290.       ENDIF
  4291.       CALL AS2DPC(ASTR,WORD)
  4292.       IF(WORD(1:3) .EQ. '#EO') THEN
  4293.          MATCH = EOF
  4294.          RETURN
  4295.       ENDIF
  4296.  
  4297. *     BEGIN THE MATCHING HERE; TABLES MUST BE IN ALPHABETICAL ORDER
  4298.  
  4299.       T1 = 1
  4300.       T2 = TABLEN
  4301.       CHP = 1
  4302. 10    IF (CHP .LE. LEN) THEN
  4303.  
  4304. *        IF WE FIND A "?", THEN GIVE THE POSSIBILITIES
  4305.  
  4306.          IF (WORD(CHP:CHP) .EQ. '?') THEN
  4307.             CALL FPRINTF(STDOUT,'^ONE OF THE FOLLOWING:\N')
  4308.             CALL OUTTBL(TABLE,T1,T2)
  4309.             MATCH = ERROR
  4310.             RETURN
  4311.          ENDIF
  4312.  
  4313. *        WHILE WORD IS LESS THAN LOWER TABLE ENTRY
  4314.  
  4315. 20       IF (T1 .LE. T2) THEN
  4316.             IF (WORD(CHP:CHP) .GT. TABLE(T1)(CHP:CHP)) THEN
  4317.                T1 = T1+1
  4318.                GOTO 20
  4319.             ENDIF
  4320.          ENDIF
  4321.  
  4322. *        WHILE WORD IS GREATER THAN UPPER TABLE ENTRY
  4323.  
  4324. 30       IF (T2 .GE. T1) THEN
  4325.             IF (WORD(CHP:CHP) .LT. TABLE(T2)(CHP:CHP)) THEN
  4326.                T2 = T2-1
  4327.                GOTO 30
  4328.             ENDIF
  4329.          ENDIF
  4330.  
  4331. *        IF WE KNOW WE HAVE A MISMATCH
  4332.  
  4333.          IF (T2 .LT. T1) THEN
  4334.             CALL FPRINTF(STDOUT,'?^DOES NOT MATCH KEYWORD - "')
  4335.             CALL PUTSTR(STDOUT,ASTR)
  4336.             CALL FPRINTF(STDOUT,'"\N')
  4337.             MATCH = ERROR
  4338.             RETURN
  4339.          ENDIF
  4340.  
  4341.          CHP = CHP+1
  4342.          GOTO 10
  4343.       ENDIF
  4344.  
  4345. *     AFTER LOOKING AT THE WHOLE WORD, IS IT STILL AMBIGUOUS?
  4346.  
  4347.       IF (T1 .NE. T2) THEN
  4348.          CALL FPRINTF(STDOUT,'?^AMBIGUOUS - "')
  4349.          CALL PUTSTR(STDOUT,ASTR)
  4350.          CALL FPRINTF(STDOUT,'"\N')
  4351.          MATCH = ERROR
  4352.  
  4353.       ELSE
  4354.          MATCH = T1
  4355.  
  4356.       ENDIF
  4357.  
  4358.  
  4359.       RETURN
  4360.       END
  4361.       SUBROUTINE MOVETOC(I, J)
  4362. *
  4363. *     SUBROUTINE MOVETOC - MOVE BOOLEAN WORD TO CHARACTER VARIABLE.
  4364. *     THIS ROUTINE MUST BE USED ONLY FOR A *10 WORD-ALIGNED CHARACTER
  4365. *     VARIABLE; ELSE, ALL HADES MAY BREAK LOOSE.
  4366. *
  4367.       J = I
  4368.       RETURN
  4369.       END
  4370.           IDENT  NEXTFN
  4371.  
  4372. ***       NEXTFN - RETURN THE NEXT FILE NAME
  4373. *
  4374. *         THIS ROUTINE CONSISTS OF 2 SUBROUTINES, ONE TO RETURN LOCAL
  4375. *         FILE NAMES AND ONE FOR PERMANENT FILE NAMES.
  4376. *
  4377.  NXTBUFL  =      400B        BUFFER LENGTH
  4378.  NXTBUF   BSS    NXTBUFL     SHARED BUFFER
  4379.  NEXTPF   SPACE  4,8
  4380. ***       NEXTPF - RETURN THE NEXT PERM FILE NAME
  4381. *
  4382. *         INTEGER FUNCTION NEXTPF RETURNS THE NEXT PERM FILE NAME FROM
  4383. *         THE USER'S CATALOG.
  4384. *
  4385. *         PFN = NEXTPF(IFLAG)
  4386. *
  4387. *         ENTRY  IFLAG = 0 TO RESET POINTERS, DON'T RETURN PF.
  4388. *                      .NE. 0 TO RETURN NEXT PF.
  4389. *         EXIT   PFN = NEXT PERM FILE NAME (L FORMAT), OR 0 IF NO
  4390. *                      MORE PERM FILES.  UNDEFINED IF IFLAG=0.
  4391. *
  4392.  PFET     FILEB  NXTBUF,NXTBUFL,FET=10
  4393.  NWCE     =      16          NUMBER OF WORDS IN CATALOG ENTRY
  4394.  PWSA     BSS    NWCE
  4395.  
  4396.           ENTRY  NEXTPF
  4397.  
  4398.  NEXTPF   EQ     *+40000B
  4399.           SB1    1
  4400.           SA2    X1          X2 = IFLAG
  4401.           NZ,X2  PFN1        CONTINUATION CALL
  4402.  
  4403.           MX6    0
  4404.           SA6    PFET+6      CLEAR CONTINUATION DATA
  4405.           SX6    NXTBUF      RESET BUFFER POINTERS
  4406.           SA6    PFET+2      IN
  4407.           SA6    A6+B1       OUT
  4408.           CATLIST  PFET      START CATLIST
  4409.           EQ     NEXTPF
  4410.  
  4411.  PFN1     READW  PFET,PWSA,NWCE    READ CATALOG ENTRY
  4412.           NG,X1  PFN2        BUFFER EMPTY
  4413.           SA1    PWSA
  4414.           MX0    42
  4415.           BX1    X0*X1       RETURN PFN
  4416.           RJ     =XZTB=      CONVERT 00 TO BLANKS
  4417.           EQ     NEXTPF
  4418.  
  4419.  PFN2     SX1    X1+B1
  4420.           NG,X1  PFN3        EOI - COMPLETE
  4421.           SX6    NXTBUF      RESET BUFFER POINTERS
  4422.           SA6    PFET+2      IN
  4423.           SA6    A6+B1       OUT
  4424.           CATLIST  PFET      FILL UP BUFFER AGAIN
  4425.           EQ     PFN1        CONTINUE
  4426.  
  4427.  PFN3     MX6    0           RETURN COMPLETE
  4428.           EQ     NEXTPF
  4429.  NEXTLF   SPACE  4,8
  4430. ***       NEXTLF - RETURN THE NEXT LOCAL FILE NAME
  4431. *
  4432. *         INTEGER FUNCTION NEXTLF RETURNS THE NEXT LOCAL FILE NAME FROM
  4433. *         THE USER'S JOB.
  4434. *
  4435. *         LFN = NEXTLF(IFLAG)
  4436. *
  4437. *         ENTRY  IFLAG = 0 TO RESET POINTERS, DON'T RETURN LF.
  4438. *                      .NE. 0 TO RETURN NEXT LF.
  4439. *         EXIT   LFN = NEXT LOCAL FILE NAME (L FORMAT), OR 0 IF NO
  4440. *                      MORE LOCAL FILES.  UNDEFINED IF IFLAG=0.
  4441. *
  4442.  LFET     FILEB  NXTBUF,NXTBUFL,FET=13
  4443.  NLFE     =      2           NUMBER OF WORDS IN FILE ENTRY
  4444.  LFPW     VFD    12/NXTBUFL/2-2,24/0,6/10B,18/NXTBUF
  4445.  LPTR     BSS    1
  4446.  
  4447.           ENTRY  NEXTLF
  4448.  
  4449.  NEXTLF   EQ     *+40000B
  4450.           SB1    1
  4451.           SA2    X1          X2 = IFLAG
  4452.           NZ,X2  LFN1        CONTINUATION CALL
  4453.  
  4454.           MX6    0
  4455.           SA6    NXTBUF      CLEAR CONTINUATION ADDRESS
  4456.           SX6    NXTBUF+1    FIRST ENTRY POINTER
  4457.           SA6    LPTR        POINTER TO NEXT ENTRY
  4458.           SA1    LFPW        POINTER WORD FOR GETFNT
  4459.           BX6    X1
  4460.           SA6    LFET+10B
  4461.           GETFNT LFET        GET FIRST BUFFER LOAD
  4462.           EQ     NEXTLF
  4463.  
  4464.  LFN1     SA1    LPTR        POINTER TO NEXT ENTRY
  4465.           SX6    X1+NLFE     INCREMENT POINTER
  4466.           SA6    A1
  4467.           SA1    X1          ENTRY WORD
  4468.           ZR,X1  LFN2        BUFFER EMPTY
  4469.           MX0    2           CHECK FILE RESIDENCE
  4470.           LX0    14-59
  4471.           BX2    X0*X1
  4472.           NZ,X2  LFN1        NOT MASS STORAGE.  GET NEXT FILE.
  4473.           MX0    42
  4474.           BX1    X0*X1       RETURN LFN
  4475.           RJ     =XZTB=      CONVERT 00 TO BLANKS
  4476.           EQ     NEXTLF
  4477.  
  4478.  LFN2     SA1    NXTBUF      IF TABLE HEADER NON-ZERO, MORE TO DO.
  4479.           ZR,X1  LFN3        COMPLETE
  4480.           SX6    NXTBUF+1    FIRST ENTRY POINTER
  4481.           SA6    LPTR        POINTER TO NEXT ENTRY
  4482.           GETFNT LFET        FILL UP BUFFER AGAIN
  4483.           EQ     LFN1        CONTINUE
  4484.  
  4485.  LFN3     MX6    0           RETURN COMPLETE
  4486.           EQ     NEXTLF
  4487.           END
  4488.       SUBROUTINE OUTTBL(TABLE,START,FIN)
  4489.  
  4490. ***   OUTTBL - OUTPUT A STRING ARRAY IN TABULAR FORMAT.
  4491. *
  4492.  
  4493.       IMPLICIT INTEGER (A-Z)
  4494.       PARAMETER (COMLIS = 0)
  4495.  
  4496. *CALL COMCKER
  4497.  
  4498.       CHARACTER*(*) TABLE(FIN)
  4499.       INTEGER START, FIN
  4500.       CHARACTER*80 LINE
  4501.       INTEGER ASTR(81)
  4502.       INTEGER COLWID, NCOLS
  4503.  
  4504.  
  4505.       COLWID = LEN(TABLE(1)) + 2
  4506.       NCOLS = 80 / COLWID
  4507.       LINE = ' '
  4508.       ICOL = 1
  4509.       DO 100 I = START,FIN
  4510.          IPOS = (ICOL-1)*COLWID + 1
  4511.          LINE(IPOS:) = TABLE(I)
  4512.          ICOL = ICOL + 1
  4513.          IF (ICOL .GT. NCOLS .OR. I .EQ. FIN) THEN
  4514.             CALL DPC2AS(LINE,ASTR,LEN(LINE))
  4515.  
  4516. *           DELETE TRAILING BLANKS
  4517.  
  4518.             J = LEN(LINE)
  4519. 10          IF (LINE(J:J) .EQ. ' ') THEN
  4520.                ASTR(J) = 0
  4521.                J = J - 1
  4522.                GO TO 10
  4523.             ENDIF
  4524.             CALL PUTSTR(STDOUT,ASTR)
  4525.             CALL PUTC(NEL,STDOUT)
  4526.             LINE = ' '
  4527.             ICOL = 1
  4528.          ENDIF
  4529. 100   CONTINUE
  4530.  
  4531.  
  4532.       RETURN
  4533.       END
  4534.       SUBROUTINE PUTC(TCH,FD)
  4535.  
  4536. ***   PUTC - PUT A CHARACTER INTO AN OUTPUT STREAM
  4537. *
  4538.  
  4539.       IMPLICIT INTEGER (A-Z)
  4540.       PARAMETER (COMLIS = 0)
  4541.  
  4542. *CALL COMCKER
  4543.  
  4544.  
  4545. *     IS THE FD VALID?
  4546.  
  4547.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  4548.          CALL DISPLA(' PUTC - INVALID FILE DESCRIPTOR',FD)
  4549.          CALL ABORT
  4550.       ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
  4551.          CALL DISPLA(' PUTC - FILE DESCRIPTOR NOT OPEN',FD)
  4552.          CALL ABORT
  4553.       ENDIF
  4554.  
  4555. *     IS IT OK TO WRITE ON THIS STREAM?
  4556.  
  4557.       IF ((FMODE(FD).AND.WR) .NE. WR) THEN
  4558.          CALL DISPLA(' PUTC - WRITE ON READ-ONLY FILE ',FD)
  4559.          CALL ABORT
  4560.       ENDIF
  4561.  
  4562. *     TRANSLATE EOLS AND NULLS AND SET THE HIGH BIT FOR CONNECTED FILES
  4563.  
  4564.       CH = TCH
  4565. 10    IF (FCSET(FD) .EQ. CSTXP) THEN
  4566.          IF (CH .EQ. NEL) THEN
  4567.             CH = CR+O"4000"
  4568.          ELSE
  4569.             CH = XOR(CH,O"4000")
  4570.          ENDIF
  4571.       ELSE IF (FCSET(FD) .NE. CSBIN) THEN
  4572.          IF (CH .EQ. NEL) THEN
  4573.             CH = 0
  4574.          ELSE IF (CH .EQ. 0) THEN
  4575.             CH = NULL
  4576.          ELSE
  4577.             CH = AND(CH,Z"7F")
  4578.          ENDIF
  4579.       ENDIF
  4580.  
  4581. *     PACK THE CHARACTER INTO THE OUTPUT BUFFER - FLUSH IF FULL
  4582.  
  4583.       IF (FCSET(FD) .EQ. CSBIN) THEN
  4584.          IF (FWSHFT(FD) .EQ. 0) THEN
  4585.             IF (FNWDS(FD) .EQ. MAXWD) CALL FFLUSH(FD)
  4586.             FWSHFT(FD) = 52
  4587.             FNWDS(FD) = FNWDS(FD)+1
  4588.             FCHBUF(FNWDS(FD),FD) = SHIFT(CH,52)
  4589.          ELSE IF (FWSHFT(FD) .EQ. 4) THEN
  4590.             FWSHFT(FD) = 56
  4591.             FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD),SHIFT(CH,-4))
  4592.             FNWDS(FD) = FNWDS(FD)+1
  4593.             FCHBUF(FNWDS(FD),FD) = SHIFT(AND(CH,Z"0F"),56)
  4594.          ELSE
  4595.             FWSHFT(FD) = FWSHFT(FD)-8
  4596.             FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD),
  4597.      -                                SHIFT(CH,FWSHFT(FD)) )
  4598.          ENDIF
  4599.  
  4600.       ELSE IF (FCSET(FD) .EQ. CSTXP) THEN
  4601.          IF (FWSHFT(FD) .EQ. 0) THEN
  4602.             IF (FNWDS(FD) .EQ. MAXWD) CALL FFLUSH(FD)
  4603.             FNWDS(FD) = FNWDS(FD)+1
  4604.             IF (FNWDS(FD) .EQ. 1) THEN
  4605.                IF (FCSET(STDIN) .EQ. CSTXP) THEN
  4606.                   FCHBUF(FNWDS(FD),FD) = O"0016 4064 4001 0000 0000"
  4607.                   FNWDS(FD) = FNWDS(FD)+1
  4608.                ENDIF
  4609.                FWSHFT(FD) = 36
  4610.                FCHBUF(FNWDS(FD),FD) = O"0007 0000 0000 0000 0000"
  4611.             ELSE
  4612.                FWSHFT(FD) = 48
  4613.                FCHBUF(FNWDS(FD),FD) = O"0000 0000 0000 0000 0000"
  4614.             ENDIF
  4615.          ELSE
  4616.             FWSHFT(FD) = FWSHFT(FD)-12
  4617.          ENDIF
  4618.          FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD),
  4619.      -                             SHIFT(CH,FWSHFT(FD)) )
  4620.  
  4621.       ELSE
  4622.          IF (FWSHFT(FD) .EQ. 0) THEN
  4623.             IF (FNWDS(FD) .EQ. MAXWD) CALL FFLUSH(FD)
  4624.             FNWDS(FD) = FNWDS(FD)+1
  4625.             FCHBUF(FNWDS(FD),FD) = O"0000 0000 0000 0000 0000"
  4626.             FWSHFT(FD) = 48
  4627.          ELSE
  4628.             FWSHFT(FD) = FWSHFT(FD)-12
  4629.          ENDIF
  4630.          FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD),
  4631.      -                             SHIFT(CH,FWSHFT(FD)) )
  4632.  
  4633.       ENDIF
  4634.  
  4635. *     FOR CONNECTED FILES ADD A LF AFTER A CR
  4636. *     FOR ALL FILES FLUSH THE BUFFER ON A NEL
  4637.  
  4638.       IF (TCH .EQ. NEL) THEN
  4639.          IF (CH .EQ. CR+O"4000") THEN
  4640.             CH = LF
  4641.             GO TO 10
  4642.          ENDIF
  4643.          CALL FFLUSH(FD)
  4644.       ENDIF
  4645.  
  4646.  
  4647.       RETURN
  4648.       END
  4649.       SUBROUTINE PUTDAY(FD,MM,DD,YY)
  4650.  
  4651. ***   OUTPUT DAY OF WEEK.
  4652. *
  4653.  
  4654.       IMPLICIT INTEGER (A-Z)
  4655.       PARAMETER (COMLIS = 0)
  4656.  
  4657. *CALL COMCKER
  4658.  
  4659.  
  4660.       IZLR(IYR,M,IDY)=MOD((13*(M+10-(M+10)/13*12)-1)/5+IDY+77
  4661.      1 +5*(IYR+(M-14)/12-(IYR+(M-14)/12)/100*100)/4
  4662.      2 +(IYR+(M-14)/12)/400-(IYR+(M-14)/12)/100*2,7)+1
  4663.  
  4664.       WKDAY = IZLR(YY,MM,DD)
  4665.       IF (WKDAY .EQ. 1) THEN
  4666.          CALL FPRINTF(FD,'^SUNDAY')
  4667.       ELSE IF (WKDAY .EQ. 2) THEN
  4668.          CALL FPRINTF(FD,'^MONDAY')
  4669.       ELSE IF (WKDAY .EQ. 3) THEN
  4670.          CALL FPRINTF(FD,'^TUESDAY')
  4671.       ELSE IF (WKDAY .EQ. 4) THEN
  4672.          CALL FPRINTF(FD,'^WEDNESDAY')
  4673.       ELSE IF (WKDAY .EQ. 5) THEN
  4674.          CALL FPRINTF(FD,'^THURSDAY')
  4675.       ELSE IF (WKDAY .EQ. 6) THEN
  4676.          CALL FPRINTF(FD,'^FRIDAY')
  4677.       ELSE
  4678.          CALL FPRINTF(FD,'^SATURDAY')
  4679.       ENDIF
  4680.  
  4681.  
  4682.       RETURN
  4683.       END
  4684.       SUBROUTINE PUTINT(FD,INT,MINWID)
  4685.  
  4686. ***   PUTINT - OUTPUT AN INTEGER.
  4687. *
  4688.  
  4689.       IMPLICIT INTEGER (A-Z)
  4690.       PARAMETER (COMLIS = 0)
  4691.  
  4692. *CALL COMCKER
  4693.  
  4694.       INTEGER STRING(21)
  4695.  
  4696.  
  4697.       WIDTH = 0
  4698.       IF (INT .LT. 0) THEN
  4699.          CALL PUTC(ASC('-'),FD)
  4700.          WIDTH = 1
  4701.       ENDIF
  4702.       VAL = IABS(INT)
  4703.       ASCII0 = ASC('0')
  4704.       NCH = 0
  4705. 10    NCH = NCH + 1
  4706.       STRING(NCH) = MOD(VAL,10) + ASCII0
  4707.       VAL = VAL / 10
  4708.       IF (VAL .NE. 0 .AND. NCH .LT. 20) GO TO 10
  4709.       WIDTH = WIDTH + NCH
  4710.  
  4711. *     NOW OUTPUT THE DIGITS
  4712.  
  4713. 20    CALL PUTC(STRING(NCH),FD)
  4714.       NCH = NCH - 1
  4715.       IF (NCH .GT. 0) GO TO 20
  4716. 30    IF (WIDTH .LT. MINWID) THEN
  4717.          CALL PUTC(BLANK,FD)
  4718.          WIDTH = WIDTH + 1
  4719.          GO TO 30
  4720.       ENDIF
  4721.  
  4722.  
  4723.       RETURN
  4724.       END
  4725.       SUBROUTINE PUTMNTH(FD,MM)
  4726.  
  4727. ***   PUTMNTH - OUTPUT THE MONTH NAME.
  4728. *
  4729.  
  4730.       IMPLICIT INTEGER (A-Z)
  4731.       PARAMETER (COMLIS = 0)
  4732.  
  4733. *CALL COMCKER
  4734.  
  4735.  
  4736.       IF (MM .EQ. 1) THEN
  4737.          CALL FPRINTF(FD,'^JANUARY',0)
  4738.       ELSE IF (MM .EQ. 2) THEN
  4739.          CALL FPRINTF(FD,'^FEBRUARY',0)
  4740.       ELSE IF (MM .EQ. 3) THEN
  4741.          CALL FPRINTF(FD,'^MARCH',0)
  4742.       ELSE IF (MM .EQ. 4) THEN
  4743.          CALL FPRINTF(FD,'^APRIL',0)
  4744.       ELSE IF (MM .EQ. 5) THEN
  4745.          CALL FPRINTF(FD,'^MAY',0)
  4746.       ELSE IF (MM .EQ. 6) THEN
  4747.          CALL FPRINTF(FD,'^JUNE',0)
  4748.       ELSE IF (MM .EQ. 7) THEN
  4749.          CALL FPRINTF(FD,'^JULY',0)
  4750.       ELSE IF (MM .EQ. 8) THEN
  4751.          CALL FPRINTF(FD,'^AUGUST',0)
  4752.       ELSE IF (MM .EQ. 9) THEN
  4753.          CALL FPRINTF(FD,'^SEPTEMBER',0)
  4754.       ELSE IF (MM .EQ. 10) THEN
  4755.          CALL FPRINTF(FD,'^OCTOBER',0)
  4756.       ELSE IF (MM .EQ. 11) THEN
  4757.          CALL FPRINTF(FD,'^NOVEMBER',0)
  4758.       ELSE IF (MM .EQ. 12) THEN
  4759.          CALL FPRINTF(FD,'^DECEMBER',0)
  4760.       ELSE
  4761.          CALL FPRINTF(FD,'PUTMNTH - NO SUCH MONTH AS @D\N',MM)
  4762.       ENDIF
  4763.  
  4764.  
  4765.       RETURN
  4766.       END
  4767.       SUBROUTINE PUTSTR(FD,STR)
  4768.  
  4769. ***   PUTSTR - OUTPUT A STRING TO AN OUTPUT STREAM.
  4770. *
  4771. *     PUTSTR WILL ADD CHARACTERS FROM THE NULL TERMINATED CHARACTER
  4772. *     BUFFER STR TO THE SPECIFIED OUTPUT STREAM.
  4773.  
  4774.       IMPLICIT INTEGER (A-Z)
  4775.       PARAMETER (COMLIS = 0)
  4776.  
  4777. *CALL COMCKER
  4778.  
  4779.       INTEGER STR(*)
  4780.  
  4781.  
  4782. *     IS THE FD VALID?
  4783.  
  4784.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  4785.          CALL DISPLA(' PUTC - INVALID FD ',FD)
  4786.          CALL ABORT
  4787.       ELSE IF (FMODE(FD) .EQ. 0) THEN
  4788.          CALL DISPLA(' PUTC - FD NOT OPEN.',FD)
  4789.          RETURN
  4790.       ENDIF
  4791.  
  4792. *     IS IT OK TO WRITE ON THIS STREAM?
  4793.  
  4794.       IF ((FMODE(FD).AND.WR) .NE. WR) THEN
  4795.          CALL DISPLA(' PUTC - WRITE ON READ-ONLY FILE ',FD)
  4796.          CALL ABORT
  4797.       ENDIF
  4798.  
  4799. *     PUT CHARS IN THE OUTPUT BUFFER
  4800.  
  4801.       I = 1
  4802. 10    IF (STR(I) .NE. 0) THEN
  4803.          CALL PUTC(STR(I),FD)
  4804.          I = I+1
  4805.          GOTO 10
  4806.       ENDIF
  4807.  
  4808.  
  4809.       RETURN
  4810.       END
  4811.       INTEGER FUNCTION RDATA()
  4812.  
  4813. ***   RDATA - READ A DATA PACKET.
  4814. *
  4815.  
  4816.       IMPLICIT INTEGER (A-Z)
  4817.       PARAMETER (COMLIS = 0)
  4818.  
  4819. *CALL COMCKER
  4820.  
  4821.  
  4822. *     CHECK RETRY COUNT
  4823.  
  4824.       IF (NUMTRY .GT. MAXRTRY) THEN
  4825.          RDATA = A
  4826.          ABORTYP = TOOMANY.OR.READING.OR.DATAERR
  4827.          RETURN
  4828.       ENDIF
  4829.       NUMTRY = NUMTRY + 1
  4830.  
  4831. *     READ A PACKET
  4832.  
  4833.       PTYP = RDPACK(LEN,NUM,PACKET)
  4834.  
  4835. *     D A T A
  4836.  
  4837.       IF (PTYP .EQ. D) THEN
  4838.          IF (NUM .NE. PACKNUM) THEN
  4839.             IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN
  4840.                CALL SNDPACK(Y,NUM,0,0)
  4841.                RDATA = STATE
  4842.             ELSE
  4843.                RDATA = A
  4844.                ABORTYP = SEQERR.OR.READING.OR.DATAERR
  4845.             ENDIF
  4846.          ELSE
  4847.             CALL BUFEMP(PACKET,FFD,LEN)
  4848.             CALL SNDPACK(Y,PACKNUM,0,0)
  4849.             NUMTRY = 0
  4850.             PACKNUM = MOD(PACKNUM+1,64)
  4851.             RDATA = STATE
  4852.          ENDIF
  4853.  
  4854. *     F I L E N A M E
  4855.  
  4856.       ELSE IF (PTYP .EQ. F) THEN
  4857.          IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN
  4858.             CALL SNDPACK(Y,NUM,0,0)
  4859.             NUMTRY = 0
  4860.             RDATA = STATE
  4861.          ELSE
  4862.             RDATA = A
  4863.             ABORTYP = SEQERR.OR.READING.OR.FILERR
  4864.          ENDIF
  4865.  
  4866. *     E O F
  4867.  
  4868.       ELSE IF (PTYP .EQ. Z) THEN
  4869.          IF (NUM .NE. PACKNUM) THEN
  4870.             RDATA = A
  4871.             ABORTYP = SEQERR.OR.READING.OR.EOFERR
  4872.          ELSE
  4873.             CALL SNDPACK(Y,PACKNUM,0,0)
  4874.             CALL FCLOSE(FFD)
  4875.             FFD = 0
  4876.             IF(LEN.GT.0 .AND. PACKET(1).EQ.D) THEN
  4877.  
  4878. *              INTERRUPTED FILE TRANSFER, UNLOAD INCOMPLETE FILE.
  4879.  
  4880.                CALL REMOVE(FILESTR)
  4881.                ABORTYP = INTRPT .OR. READING
  4882.             ENDIF
  4883.             PACKNUM = MOD(PACKNUM+1,64)
  4884.             RDATA = F
  4885.          ENDIF
  4886.  
  4887. *     E R R O R
  4888.  
  4889.       ELSE IF (PTYP .EQ. E) THEN
  4890.          RDATA = E
  4891.          CALL EXPSTR(PACKET, LEN, MICMSG(16))
  4892.          ABORTYP = READING .OR. MICERR
  4893.          RETURN
  4894.  
  4895. *     B A D   C H E C K S U M
  4896.  
  4897.       ELSE IF (PTYP .EQ. ERROR) THEN
  4898.          RDATA = STATE
  4899.          CALL SNDPACK(N,PACKNUM,0,0)
  4900.  
  4901. *     B A D   T Y P E
  4902.  
  4903.       ELSE
  4904.          RDATA = A
  4905.          ABORTYP = INVALID.OR.READING.OR.DATAERR
  4906.  
  4907.       ENDIF
  4908.  
  4909.  
  4910.       RETURN
  4911.       END
  4912.       INTEGER FUNCTION RDPACK(LEN,NUM,DATA)
  4913.  
  4914. ***   RDPACK - READ A PACKET OF INFORMATION.
  4915. *
  4916. *     RDPACK WILL READ A PACKET OF DATA AND RETURN THE PACKET TYPE
  4917. *     AS A RESULT.  IF THE PACKET CONTAINS AN ERROR (CHECKSUM) THEN
  4918. *     ERROR WILL BE RETURNED.  LEN, NUM, AND DATA WILL BE SET ACCORDING
  4919. *     TO THE FIELDS OF THE PACKET.
  4920. *
  4921. *     IT MAY WELL BE THAT CHARACTERS ARE LOST IN TRANSMISSION, MAKING
  4922. *     A PACKET SHORTER THAN EXPECTED.  THIS SHOULD CAUSE A REQUEST FOR
  4923. *     RETRANSMISSION (NAK).  RDPACK LOOKS FOR AN NEL RETURNED BY
  4924. *     GETC TO TELL IT WHERE THE END OF THE DATA IS.
  4925. *
  4926. *     IF THE USER ENTERS A CTRL/C OR CTRL/T AS THE FIRST CHARACTER OF
  4927. *     A LINE, RETURN AN ABORT.  THIS ALLOWS THE PROTOCOL TO BE ABORTED
  4928. *     IF NECESSARY.
  4929. *
  4930.  
  4931.       IMPLICIT INTEGER (A-Z)
  4932.       PARAMETER (COMLIS = 0)
  4933.  
  4934. *CALL COMCKER
  4935.  
  4936.       INTEGER DATA(*)
  4937.       LOGICAL TYPE0
  4938.       LOGICAL WAITINP
  4939.  
  4940. *CALL COMXKER
  4941.  
  4942.  
  4943. *     LOG INCOMING PACKETS
  4944.  
  4945.       IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
  4946.          CALL FPRINTF(DEBUGFD,'^R^E^A^D^I^N^G:\N',0)
  4947.       ENDIF
  4948.       NCH = 0
  4949.  
  4950. *     HUNT FOR THE START OF THE PACKET
  4951.  
  4952. 10    CONTINUE
  4953.  
  4954. *     WAIT 'STIMOUT' SECONDS TO RECEIVE PACKET IF 'WAITPAK' IS TRUE.
  4955.  
  4956.       IF(WAITPAK .AND. .NOT.WAITINP(STIMOUT)) THEN
  4957.          RDPACK = ERROR
  4958.          CALL FFLUSH(STDIN)
  4959.          RETURN
  4960.       ENDIF
  4961.       CH = GETC(STDIN, CH)
  4962.       IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
  4963.          CALL PUTC(CH,DEBUGFD)
  4964.       ENDIF
  4965.       IF(CH .NE. SSYNC) THEN
  4966.          IF(CH .EQ. NEL) THEN
  4967.             IF (DEBUG .NE. 0) THEN
  4968.                CALL FPRINTF(DEBUGFD,'\N<^N^U^L^L ^P^A^C^K^E^T>\N',0)
  4969.             ENDIF
  4970.             CALL FFLUSH(STDIN)
  4971.             RDPACK = ERROR
  4972.             RETURN
  4973.          ELSE IF(CH.EQ.DC4 .OR. CH.EQ.ETX) THEN
  4974.             CALL FFLUSH(STDIN)
  4975.             RDPACK = A
  4976.             RETURN
  4977.          ENDIF
  4978.          NCH = NCH+1
  4979.          GOTO 10
  4980.       ENDIF
  4981.  
  4982.       CHKSUM = LEN = 0
  4983.  
  4984. *     PARSE EACH FIELD OF THE PACKET
  4985. *     FIELD IS PACKET FIELD, 'LEN' TO 'CHECK'.
  4986. *     XFIELD IS EXT-LENGTH PACKET INTERNAL FIELD, 'LENX1' TO 'HCHECK'.
  4987.  
  4988.       FIELD = 1
  4989.       XFIELD = 1
  4990. 20    IF (FIELD .LE. 5) THEN
  4991.  
  4992. *        A CHARACTER READ IN FIELD 4 HERE IS THE FIRST CHAR OF THE
  4993. *        DATA FIELD OR THE CHECKSUM CHARACTER IF THE DATA FIELD IS EMPTY
  4994. *
  4995. *        *LEN* IS THE >DATA< LENGTH
  4996.  
  4997.          IF (FIELD .LE. 4 .OR. LEN .GT. 0) THEN
  4998.             IF(GETC(STDIN,CH) .EQ. NEL) THEN
  4999.                IF (DEBUG .NE. 0) THEN
  5000.                  CALL FPRINTF(DEBUGFD,'\N<^S^H^O^R^T ^P^A^C^K^E^T>\N',0)
  5001.                ENDIF
  5002.                CALL FFLUSH(STDIN)
  5003.                RDPACK = ERROR
  5004.                RETURN
  5005.             ENDIF
  5006.             IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
  5007.                CALL PUTC(CH,DEBUGFD)
  5008.             ENDIF
  5009.             IF (CH .EQ. SSYNC) FIELD = 0
  5010.             NCH = NCH+1
  5011.          ENDIF
  5012.  
  5013.          IF (FIELD .LE. 3) CHKSUM = CHKSUM+CH
  5014.  
  5015. *        R E S Y N C   ( 0 )
  5016.  
  5017.          IF (FIELD .EQ. 0) THEN
  5018.             CHKSUM = 0
  5019.             IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
  5020.                CALL FPRINTF(DEBUGFD,'\N<^R^E^S^Y^N^C>\N',0)
  5021.                CALL FPRINTF(DEBUGFD,'^R^E^A^D^I^N^G:\N@C',SSYNC)
  5022.             ENDIF
  5023.  
  5024. *        L E N G T H   ( 1 )
  5025.  
  5026.          ELSE IF (FIELD .EQ. 1) THEN
  5027.             LEN = UNCHAR(CH-3)
  5028.             TYPE0 = (LEN .EQ. -3)
  5029.  
  5030. *        P A C K E T   N U M B E R   ( 2 )
  5031.  
  5032.          ELSE IF (FIELD .EQ. 2) THEN
  5033.             NUM = UNCHAR(CH)
  5034.  
  5035. *        P A C K E T   T Y P E   ( 3 )
  5036.  
  5037.          ELSE IF (FIELD .EQ. 3) THEN
  5038.             TYPE = CH
  5039.  
  5040. *        D A T A   ( 4 )
  5041.  
  5042.          ELSE IF (FIELD .EQ. 4 .AND. LEN .GT. 0) THEN
  5043.             CHKSUM = CHKSUM+CH
  5044.             DATA(1) = CH
  5045.  
  5046. *           READ 2ND-LEN CHARS OF DATA
  5047.  
  5048.             DO 100 I=2,LEN
  5049.                IF(GETC(STDIN,CH) .EQ. NEL) THEN
  5050.                   IF (DEBUG .NE. 0) THEN
  5051.                      CALL FPRINTF(DEBUGFD,
  5052.      +               '\N<^S^H^O^R^T ^P^A^C^K^E^T>\N',0)
  5053.                   ENDIF
  5054.                   CALL FFLUSH(STDIN)
  5055.                   RDPACK = ERROR
  5056.                   RETURN
  5057.                ENDIF
  5058.                NCH = NCH+1
  5059.                IF (CH .EQ. SSYNC) THEN
  5060.                   FIELD = 0
  5061.                   GO TO 20
  5062.                ENDIF
  5063.                IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
  5064.                   CALL PUTC(CH,DEBUGFD)
  5065.                ENDIF
  5066.                CHKSUM = CHKSUM+CH
  5067.                DATA(I) = CH
  5068.  100        CONTINUE
  5069.  
  5070. *        LENX1, LENX2, HCHECK
  5071.  
  5072.          ELSE IF(FIELD.EQ.4 .AND. TYPE0 .AND. LEN.LT.0) THEN
  5073.             FIELD = 3
  5074.             CHKSUM = CHKSUM + CH
  5075.             IF(XFIELD .EQ. 1) THEN
  5076.                EXLEN = UNCHAR(CH)*95
  5077.             ELSE IF(XFIELD .EQ. 2) THEN
  5078.                EXLEN = EXLEN + UNCHAR(CH)
  5079.             ELSE IF(XFIELD .EQ. 3) THEN
  5080.                LEN = EXLEN - 1
  5081.                HCH = CHKSUM - CH
  5082.                HCH = AND(HCH+(AND(HCH,O"300")/O"100"),O"77")
  5083.                IF(HCH .NE. UNCHAR(CH)) THEN
  5084.                   FIELD = 6
  5085.                   CHKSUM = HCH
  5086.                   IF(DEBUG.NE.0) CALL FPRINTF(DEBUGFD,'\NHEADER CHKSUM',
  5087.      +              0,0,0,0)
  5088.                ENDIF
  5089.             ENDIF
  5090.             XFIELD = XFIELD + 1
  5091.  
  5092. *        C H E C K S U M   ( 5 )
  5093.  
  5094.          ELSE IF (FIELD .EQ. 5) THEN
  5095.             DATA(LEN+1) = 0
  5096.             CHKSUM = AND(CHKSUM+(AND(CHKSUM,O"300")/O"100"),O"77")
  5097.  
  5098.          ENDIF
  5099.  
  5100. *        PROCESS NEXT PACKET FIELD
  5101.  
  5102.          FIELD = FIELD+1
  5103.          GOTO 20
  5104.       ENDIF
  5105.  
  5106. *     DOES THE CHECKSUM MATCH?
  5107.  
  5108.       IF (CHKSUM .NE. UNCHAR(CH)) THEN
  5109.          RDPACK = ERROR
  5110.          RCHOVRH = RCHOVRH+NCH
  5111.          IF (DEBUG .NE. 0) THEN
  5112.             CALL FPRINTF(DEBUGFD,'\NCKSUM ERROR, FOUND @D ',UNCHAR(CH))
  5113.             CALL FPRINTF(DEBUGFD,'NEEDED @D\N',CHKSUM)
  5114.          ENDIF
  5115.       ELSE
  5116.          RDPACK = TYPE
  5117.          RCHOVRH = RCHOVRH+NCH-LEN
  5118.          IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
  5119.             CALL PUTC(NEL,DEBUGFD)
  5120.          ENDIF
  5121.       ENDIF
  5122.       RCHCNT = RCHCNT+NCH
  5123.  
  5124. *     FLUSH ANY END-OF-LINE CHARACTERS AND OTHER GARBAGE
  5125.  
  5126.       CALL FFLUSH(STDIN)
  5127.  
  5128.  
  5129.       RETURN
  5130.       END
  5131.       SUBROUTINE RDPARAM(PDATA)
  5132.  
  5133. ***   RDPARAM - GET THE PACKET PARAMETERS FROM THE OTHER KERMIT.
  5134. *
  5135.  
  5136.       IMPLICIT INTEGER (A-Z)
  5137.       PARAMETER (COMLIS = 0)
  5138.  
  5139. *CALL COMCKER
  5140.  
  5141.       BOOLEAN PDATA(*)
  5142.       INTEGER DPARAMS(12), RPARAMS(12)
  5143.       EQUIVALENCE (RPARAMS,RPKSIZE)
  5144.       EQUIVALENCE (DPARAMS,DPKSIZE)
  5145.  
  5146. *CALL COMXKER
  5147.  
  5148.  
  5149. *     INITIALIZE DEFAULT PACKET PARAMETERS.
  5150.  
  5151.       DO 10 I=1,12
  5152.          RPARAMS(I) = DPARAMS(I)
  5153.  10   CONTINUE
  5154.  
  5155.  
  5156. *     MOVE THE FIRST (UP TO 9) RECEIVED PARAMETERS TO RPARAMS BLOCK.
  5157. *     THEN COMPLETE SIZE NEGOTIATIONS AND CHECK CAPABILITIES.
  5158.  
  5159.       PDATAL = SLEN(PDATA)
  5160.       DO 20 I=1, MIN0(PDATAL, 9)
  5161.  
  5162. *     PAD CHARACTER
  5163.  
  5164.       IF (I .EQ. 4) THEN
  5165.         RPARAMS(I) = CTL(PDATA(I))
  5166.  
  5167. *     CONTROL, EIGHT-BIT, OR REPEAT PREFIX CHARACTER
  5168.  
  5169.       ELSE IF (I.EQ.6 .OR. I.EQ.7 .OR. I.EQ.9) THEN
  5170.          IF ( (PDATA(I).GE.33 .AND. PDATA(I).LE.62) .OR.
  5171.      +        (PDATA(I).GE.96 .AND. PDATA(I).LE.126) ) THEN
  5172.             RPARAMS(I) = PDATA(I)
  5173.          ENDIF
  5174.  
  5175. *     OTHER FIELDS - SET WITH *UNCHAR* UNLESS DEFAULTED
  5176.  
  5177.       ELSE IF (UNCHAR(PDATA(I)) .NE. 0) THEN
  5178.          RPARAMS(I) = UNCHAR(PDATA(I))
  5179.  
  5180.       ENDIF
  5181.  
  5182. 20    CONTINUE
  5183.  
  5184. *     DETERMINE SIZE OF PACKETS TO SEND.  CHECK FOR LONG-PACKET
  5185. *     CAPABILITIES OF OTHER END.
  5186.  
  5187.       RPKSIZE = MIN0(DPKSIZE, RPKSIZE)
  5188.  
  5189.       IF(PDATAL.GE.10 .AND. (UNCHAR(PDATA(10)).AND.CAPAS5).NE.0) THEN
  5190.          I = 10
  5191. 30       J = UNCHAR(PDATA(I))
  5192.          IF((J .AND. CAPAS6) .NE. 0) GOTO 30
  5193.          RMAXLX = 0
  5194.          IF(PDATAL .GE. I+3) THEN
  5195.             RMAXLX = UNCHAR(PDATA(I+2))*95 +
  5196.      +               UNCHAR(PDATA(I+3))
  5197.          ENDIF
  5198.          IF(RMAXLX .EQ. 0) RMAXLX = 500
  5199.          RPKSIZE = RMAXLX
  5200.       ENDIF
  5201.  
  5202.       RPKSIZE = MIN0(DPKSIZE, RPKSIZE)
  5203.  
  5204.  
  5205.       RETURN
  5206.       END
  5207.       INTEGER FUNCTION RECEIVE(ISTATE)
  5208.  
  5209. ***   RECEIVE - RECEIVE FILE STATE SWITCHING ROUTINE.
  5210. *
  5211.  
  5212.       IMPLICIT INTEGER (A-Z)
  5213.       PARAMETER (COMLIS = 0)
  5214.  
  5215. *CALL COMCKER
  5216.  
  5217.  
  5218. *     INITIALIZE STATISTICS VARIABLES
  5219.  
  5220.          ABORTYP = 0
  5221.       SCHCNT = 0
  5222.       RCHCNT = 0
  5223.       SCHOVRH = 0
  5224.       RCHOVRH = 0
  5225.  
  5226. *     SET PACKET RETRY COUNT & CURRENT STATE
  5227.  
  5228.       NUMTRY = 0
  5229.       STATE = ISTATE
  5230.  
  5231. *     TAKE APPROPRIATE ACTION FOR THE CURRENT STATE
  5232.  
  5233.  10   IF ((DEBUG.AND.DBGSTAT).NE.0) THEN
  5234.          CALL FPRINTF(DEBUGFD,'\N^S^T^A^T^E=@C  ^P^A^C^K^E^T=@2D\N',
  5235.      +    STATE,PACKNUM)
  5236.       ENDIF
  5237.       IF (STATE .EQ. D) THEN
  5238.          STATE = RDATA()
  5239.          GOTO 10
  5240.       ELSE IF (STATE .EQ. F) THEN
  5241.          STATE = RFILE()
  5242.          GOTO 10
  5243.       ELSE IF (STATE .EQ. R) THEN
  5244.          STATE = RINIT()
  5245.          CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
  5246.          STARTIM = HR * 3600 + MIN * 60 + SEC
  5247.          GOTO 10
  5248.       ELSE IF (STATE .EQ. C) THEN
  5249.          CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
  5250.          ENDTIM = HR * 3600 + MIN * 60 + SEC
  5251.          RECEIVE = OK
  5252.       ELSE IF (STATE .EQ. E) THEN
  5253.          IF (FFD .NE. CLOSED) THEN
  5254.             CALL FCLOSE(FFD)
  5255.             CALL REMOVE(FILESTR)
  5256.          ENDIF
  5257.          RECEIVE = ERROR
  5258.       ELSE IF (STATE .EQ. A) THEN
  5259.          CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
  5260.          ENDTIM = HR * 3600 + MIN * 60 + SEC
  5261.          IF (FFD .NE. CLOSED) THEN
  5262.             CALL FCLOSE(FFD)
  5263.             CALL REMOVE(FILESTR)
  5264.          ENDIF
  5265.          CALL GETEMSG(ERRMSG(15))
  5266.          CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
  5267.          RECEIVE = ERROR
  5268.       ELSE
  5269.          CALL DISPLA(' RECEIVE - STATE ERROR = ',STATE)
  5270.          IF (FFD .NE. CLOSED) CALL FCLOSE(FFD)
  5271.          RECEIVE = ERROR
  5272.       ENDIF
  5273.  
  5274.  
  5275.       RETURN
  5276.       END
  5277.       SUBROUTINE REMOVE(FN)
  5278.  
  5279. ***   REMOVE - REMOVE A FILE FROM THE LOCAL FILE LIST.
  5280. *
  5281.  
  5282.       IMPLICIT INTEGER (A-Z)
  5283.       PARAMETER (COMLIS = 0)
  5284.  
  5285. *CALL COMCKER
  5286.  
  5287.       BOOLEAN FN(*)
  5288.       CHARACTER*10 LFN
  5289.  
  5290.  
  5291. *     QUIT IF NOTHING USEFUL IN THE FILE NAME ARRAY.
  5292.  
  5293.       IF(FN(1) .EQ. 0) RETURN
  5294.  
  5295. *     CONVERT THE FILE NAME TO DISPLAY CODE.
  5296.  
  5297.       CALL AS2DPC(FN,LFN)
  5298.  
  5299. *     GET RID OF THE FILE.
  5300.  
  5301.       CALL RETFILE(LFN)
  5302.  
  5303.  
  5304.       RETURN
  5305.       END
  5306.       INTEGER FUNCTION RFILE()
  5307.  
  5308. ***   RFILE - READ A FILENAME PACKET.
  5309. *
  5310. *     RFILE EXPECTS TO SEE A FILENAME (TYPE F) PACKET.  HOWEVER, IT MAY
  5311. *     FIND A SEND-INIT RETRY, END-OF-FILE RETRY OR BREAK PACKET.
  5312.  
  5313.       IMPLICIT INTEGER (A-Z)
  5314.       PARAMETER (COMLIS = 0)
  5315.  
  5316. *CALL COMCKER
  5317.  
  5318.       CHARACTER*20 FILENAM
  5319.  
  5320.  
  5321.       IF (NUMTRY .GT. MAXRTRY) THEN
  5322.          RFILE = A
  5323.          ABORTYP = TOOMANY.OR.READING.OR.FILERR
  5324.          RETURN
  5325.       ENDIF
  5326.       NUMTRY = NUMTRY + 1
  5327.  
  5328. *     READ A PACKET
  5329.  
  5330.       PTYP = RDPACK(LEN,NUM,PACKET)
  5331.  
  5332. *     F I L E N A M E
  5333.  
  5334.       IF (PTYP .EQ. F) THEN
  5335.          IF (NUM .NE. PACKNUM) THEN
  5336.             RFILE = A
  5337.             ABORTYP = SEQERR.OR.READING.OR.FILERR
  5338.             RETURN
  5339.          ENDIF
  5340.          CALL EXPSTR(PACKET, LEN, FILESTR)
  5341.          CALL AS2DPC(FILESTR, FILENAM)
  5342.          CALL FILCHK(FILENAM)
  5343.          CALL DPC2AS(FILENAM, FILESTR, 7)
  5344.          IF (FILMODE .EQ. TEXT) THEN
  5345.             FFD = FOPEN(FILENAM, CREATE, TXTMODE)
  5346.          ELSE
  5347.             FFD = FOPEN(FILENAM, CREATE, CSBIN)
  5348.          ENDIF
  5349.          IF (FFD .EQ. ERROR) THEN
  5350.             FFD = CLOSED
  5351.             RFILE = A
  5352.             ABORTYP = LCLFILE.OR.READING.OR.FILERR
  5353.          ELSE
  5354.             IF (DEBUG .NE. 0) CALL FPRINTF(DEBUGFD,
  5355.      +         '^R^E^C^E^I^V^I^N^G ^F^I^L^E: @S\N',FILESTR,0,0,0)
  5356.  
  5357. *           SEND FILE NAME USED BACK TO MICRO.
  5358.  
  5359.             CALL SNDPACK(Y, NUM, LEN, FILESTR)
  5360.             NUMTRY = 0
  5361.             PACKNUM = MOD(PACKNUM+1,64)
  5362.             RFILE = D
  5363.          ENDIF
  5364.  
  5365. *     S E N D - I N I T
  5366.  
  5367.       ELSE IF (PTYP .EQ. S) THEN
  5368.          IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN
  5369.             CALL SNDPAR(Y,PACKET,LEN)
  5370.             CALL SNDPACK(Y,NUM,LEN,PACKET)
  5371.             NUMTRY = 0
  5372.             RFILE = STATE
  5373.          ELSE
  5374.             RFILE = A
  5375.             ABORTYP = SEQERR.OR.READING.OR.INITERR
  5376.          ENDIF
  5377.  
  5378. *     E O F
  5379.  
  5380.       ELSE IF (PTYP .EQ. Z) THEN
  5381.          IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN
  5382.             CALL SNDPACK(Y,NUM,0,0)
  5383.             NUMTRY = 0
  5384.             RFILE = STATE
  5385.          ELSE
  5386.             RFILE = A
  5387.             ABORTYP = SEQERR.OR.READING.OR.EOFERR
  5388.          ENDIF
  5389.  
  5390. *     B R E A K
  5391.  
  5392.       ELSE IF (PTYP .EQ. B) THEN
  5393.          IF (NUM .NE. PACKNUM) THEN
  5394.             RFILE = A
  5395.             ABORTYP = SEQERR.OR.READING.OR.BRKERR
  5396.          ELSE
  5397.             CALL SNDPACK(Y,PACKNUM,0,0)
  5398.             RFILE = C
  5399.          ENDIF
  5400.  
  5401. *     E R R O R
  5402.  
  5403.       ELSE IF (PTYP .EQ. E) THEN
  5404.          RFILE = E
  5405.          RETURN
  5406.  
  5407. *     B A D   C H E C K S U M
  5408.  
  5409.       ELSE IF (PTYP .EQ. ERROR) THEN
  5410.          RFILE = STATE
  5411.          CALL SNDPACK(N,PACKNUM,0,0)
  5412.  
  5413. *     B A D   T Y P E
  5414.  
  5415.       ELSE
  5416.          RFILE = A
  5417.          ABORTYP = INVALID.OR.READING.OR.FILERR
  5418.  
  5419.       ENDIF
  5420.  
  5421.  
  5422.       RETURN
  5423.       END
  5424.       INTEGER FUNCTION RINIT()
  5425.  
  5426. ***   RINIT - RECEIVE A SEND-INIT PACKET.
  5427. *
  5428.  
  5429.       IMPLICIT INTEGER (A-Z)
  5430.       PARAMETER (COMLIS = 0)
  5431.  
  5432. *CALL COMCKER
  5433.  
  5434.  
  5435. *     CLEAN OUT FILESTR ARRAY SO REMOVE DOES NOT DO DIRE THINGS
  5436. *     TO THE PREVIOUSLY RECEIVED FILE IF WE DIE BEFORE WE GET
  5437. *     THE NEW FILE SPECIFICATION.
  5438.  
  5439.       DO 10 I=1, IPKSIZE
  5440.  10       FILESTR(I) = 0
  5441.  
  5442. *     CHECK RETRY COUNT
  5443.  
  5444.       IF (NUMTRY .GT. MAXRINI) THEN
  5445.          RINIT = A
  5446.          ABORTYP = TOOMANY.OR.READING.OR.INITERR
  5447.          RETURN
  5448.       ENDIF
  5449.       NUMTRY = NUMTRY+1
  5450.  
  5451. *     IF AN TRASH PACKET IS READ, THE SEQUENCE NUMBER IN THE PACKET
  5452. *     MAY BE INVALID, SO THAT WHEN A NAK IS SENT (BELOW), WE
  5453. *     USE PACKNUM AS THE NAK SEQUENCE NUMBER.  SET PACKNUM
  5454. *     TO A VALID STARTING VALUE.
  5455.  
  5456.       PACKNUM = 0
  5457.  
  5458.  
  5459. *     READ A PACKET (SHOULD BE INIT).  ALLOW SWAPOUT WHILE WAITING.
  5460.  
  5461.       WAITPAK = .FALSE.
  5462.       PTYP = RDPACK(LEN, NUM, PACKET)
  5463.       WAITPAK = .TRUE.
  5464.  
  5465. *     S E N D - I N I T
  5466.  
  5467.       IF (PTYP .EQ. S) THEN
  5468.          PACKNUM = NUM
  5469.          CALL RDPARAM(PACKET)
  5470.          CALL SNDPAR(Y,PACKET,LEN)
  5471.          CALL SNDPACK(Y,NUM,LEN,PACKET)
  5472.          NUMTRY = 0
  5473.          PACKNUM = MOD(PACKNUM+1,64)
  5474.          RINIT = F
  5475.  
  5476. *     B A D   C H E C K S U M
  5477.  
  5478.       ELSE IF (PTYP .EQ. ERROR) THEN
  5479.          RINIT = STATE
  5480.          CALL SNDPACK(N,PACKNUM,0,0)
  5481.  
  5482. *     B A D   T Y P E
  5483.  
  5484.       ELSE
  5485.          RINIT = A
  5486.          ABORTYP = INVALID.OR.READING.OR.INITERR
  5487.  
  5488.       ENDIF
  5489.  
  5490.  
  5491.       RETURN
  5492.       END
  5493.       INTEGER FUNCTION SBREAK()
  5494.  
  5495. ***   SBREAK - SEND THE BREAK PACKET AND WAIT FOR REPLY.
  5496. *
  5497.  
  5498.       IMPLICIT INTEGER (A-Z)
  5499.       PARAMETER (COMLIS = 0)
  5500.  
  5501. *CALL COMCKER
  5502.  
  5503.  
  5504. *     HAVE WE TRIED THIS TOO MANY TIMES?
  5505.  
  5506.       IF (NUMTRY .GT. MAXRTRY) THEN
  5507.          SBREAK = A
  5508.          ABORTYP = TOOMANY.OR.SENDING.OR.BRKERR
  5509.          RETURN
  5510.       ENDIF
  5511.       NUMTRY = NUMTRY + 1
  5512.  
  5513. *     SEND THE BREAK PACKET
  5514.  
  5515.       CALL SNDPACK(B,PACKNUM,0,0)
  5516.  
  5517. *     READ THE REPLY
  5518.  
  5519.       PTYP = RDPACK(LEN,NUM,RECPACK)
  5520.  
  5521. *     N A K
  5522.  
  5523.       IF (PTYP .EQ. N) THEN
  5524.          IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
  5525.             SBREAK = STATE
  5526.             RETURN
  5527.          ELSE
  5528.             PTYP = Y
  5529.             NUM = NUM-1
  5530.          ENDIF
  5531.       ENDIF
  5532.  
  5533. *     A C K
  5534.  
  5535.       IF (PTYP .EQ. Y) THEN
  5536.          IF (PACKNUM .NE. NUM) THEN
  5537.             SBREAK = STATE
  5538.             RETURN
  5539.          ENDIF
  5540.          NUMTRY = 0
  5541.          PACKNUM = MOD(PACKNUM+1,64)
  5542.          SBREAK = C
  5543.  
  5544. *     E R R O R
  5545.  
  5546.       ELSE IF (PTYP .EQ. E) THEN
  5547.          SBREAK = E
  5548.          RETURN
  5549.  
  5550. *     B A D   C H E C K S U M
  5551.  
  5552.       ELSE IF (PTYP .EQ. ERROR) THEN
  5553.          SBREAK = STATE
  5554.  
  5555. *     B A D   T Y P E
  5556.  
  5557.       ELSE
  5558.          SBREAK = A
  5559.          ABORTYP = INVALID.OR.SENDING.OR.BRKERR
  5560.  
  5561.       ENDIF
  5562.  
  5563.  
  5564.       RETURN
  5565.       END
  5566.       INTEGER FUNCTION SDATA()
  5567.  
  5568. ***   SDATA - SEND A DATA PACKET AND WAIT FOR REPLY.
  5569. *
  5570.  
  5571.       IMPLICIT INTEGER (A-Z)
  5572.       PARAMETER (COMLIS = 0)
  5573.  
  5574. *CALL COMCKER
  5575.  
  5576.          CHARACTER LFN*10
  5577.  
  5578.  
  5579. *     HAVE WE TRIED THIS TOO MANY TIMES?
  5580.  
  5581.       IF (NUMTRY .GT. MAXRTRY) THEN
  5582.          SDATA = A
  5583.          ABORTYP = TOOMANY.OR.SENDING.OR.DATAERR
  5584.          RETURN
  5585.       ENDIF
  5586.       NUMTRY = NUMTRY + 1
  5587.  
  5588. *     SEND THE CURRENT DATA BUFFER
  5589.  
  5590.       IF (PSIZE .EQ. EOF) THEN
  5591.          SDATA = Z
  5592.          RETURN
  5593.       ENDIF
  5594.       CALL SNDPACK(D,PACKNUM,PSIZE,PACKET)
  5595.  
  5596. *     READ THE REPLY
  5597.  
  5598.       PTYP = RDPACK(LEN,NUM,RECPACK)
  5599.  
  5600. *     N A K
  5601.  
  5602.       IF (PTYP .EQ. N) THEN
  5603.          IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
  5604.             SDATA = STATE
  5605.             RETURN
  5606.          ELSE
  5607.             PTYP = Y
  5608.             NUM = NUM-1
  5609.          ENDIF
  5610.       ENDIF
  5611.  
  5612. *     A C K
  5613.  
  5614.       IF (PTYP .EQ. Y) THEN
  5615.          IF (PACKNUM .NE. NUM) THEN
  5616.             SDATA = STATE
  5617.             RETURN
  5618.          ENDIF
  5619.          NUMTRY = 0
  5620.          PACKNUM = MOD(PACKNUM+1,64)
  5621.          PSIZE = BUFFILL(FFD,PACKET)
  5622.          IF (PSIZE .EQ. EOF) THEN
  5623.             SDATA = Z
  5624.          ELSE IF(LEN.GT.0 .AND. RECPACK(1).EQ.X) THEN
  5625.  
  5626. *           INTERRUPT FILE TRANSFER
  5627.  
  5628.             ABORTYP = INTRPT .OR. SENDING
  5629.             SDATA = Z
  5630.          ELSE IF(LEN.GT.0 .AND. RECPACK(1).EQ.Z) THEN
  5631.  
  5632. *           INTERRUPT GROUP TRANSFER
  5633. *           EAT UP REST OF FILE-SEND LIST
  5634.  
  5635.             ABORTYP = INTRPT .OR. SENDING
  5636.             SDATA = Z
  5637. 10          IF(LOCFILE) THEN
  5638.                CALL GETLFN(LFN)
  5639.             ELSE
  5640.                CALL GETPFN(LFN)
  5641.             ENDIF
  5642.             IF(LFN .NE. ' ') GOTO 10
  5643.          ELSE
  5644.             SDATA = STATE
  5645.          ENDIF
  5646.  
  5647. *     E R R O R
  5648.  
  5649.       ELSE IF (PTYP .EQ. E) THEN
  5650.          SDATA = E
  5651.          CALL EXPSTR(RECPACK, LEN, MICMSG(16))
  5652.          ABORTYP = SENDING .OR. MICERR
  5653.          RETURN
  5654.  
  5655. *     B A D   C H E C K S U M
  5656.  
  5657.       ELSE IF (PTYP .EQ. ERROR) THEN
  5658.          SDATA = STATE
  5659.  
  5660. *     B A D   T Y P E
  5661.  
  5662.       ELSE
  5663.          SDATA = A
  5664.          ABORTYP = INVALID.OR.SENDING.OR.DATAERR
  5665.  
  5666.       ENDIF
  5667.  
  5668.  
  5669.       RETURN
  5670.       END
  5671.       INTEGER FUNCTION SEND(SENDTYP, STR)
  5672.  
  5673. ***   SEND - SEND FILE STATE SWITCHING ROUTINE
  5674. *
  5675. *     THE FILENAME TO SEND IS ASSUMED TO HAVE ALREADY BEEN
  5676. *     OBTAINED AND SET IN ASCII STRING BUFFER FILESTR.
  5677. *
  5678. *     ENTRY:   SENDTYP - F OR X SEND TYPE FOR 'SFILE'
  5679. *              STR - CHARACTER MESSAGE STRING IF X TYPE SEND
  5680. *
  5681. *     F TYPE SEND IS FOR NORMAL FILE TRANSFER.
  5682. *     X TYPE SEND ALLOWS TEXT TRANSFER TO THE REMOTE KERMIT WITH A
  5683. *     HEADER TEXT STRING.
  5684. *
  5685.  
  5686.       IMPLICIT INTEGER (A-Z)
  5687.       PARAMETER (COMLIS = 0)
  5688.  
  5689. *CALL COMCKER
  5690.  
  5691.       CHARACTER STR*(*)
  5692.  
  5693. *     INITIALIZE STATICS VARIABLES
  5694.  
  5695.          ABORTYP = 0
  5696.       SCHCNT = 0
  5697.       RCHCNT = 0
  5698.       SCHOVRH = 0
  5699.       RCHOVRH = 0
  5700.       STATE = S
  5701.       NUMTRY = 0
  5702.  
  5703. *     TAKE APPROPRIATE ACTION FOR THE CURRENT STATE
  5704.  
  5705.  10   IF ((DEBUG.AND.DBGSTAT).NE.0) THEN
  5706.          CALL FPRINTF(DEBUGFD,'\N^S^T^A^T^E=@C  ^P^A^C^K^E^T=@2D\N',
  5707.      +    STATE,PACKNUM)
  5708.       ENDIF
  5709.       IF (STATE .EQ. D) THEN
  5710.          STATE = SDATA()
  5711.          GOTO 10
  5712.       ELSE IF (STATE .EQ. F) THEN
  5713.          STATE = SFILE(SENDTYP, STR)
  5714.          GOTO 10
  5715.       ELSE IF (STATE .EQ. Z) THEN
  5716.          STATE = SEOF()
  5717.          GOTO 10
  5718.       ELSE IF (STATE .EQ. S) THEN
  5719.          STATE = SINIT()
  5720.          CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
  5721.          STARTIM = HR * 3600 + MIN * 60 + SEC
  5722.          GOTO 10
  5723.       ELSE IF (STATE .EQ. B) THEN
  5724.          STATE = SBREAK()
  5725.          GOTO 10
  5726.       ELSE IF (STATE .EQ. C) THEN
  5727.          CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
  5728.          ENDTIM = HR * 3600 + MIN * 60 + SEC
  5729.          SEND = OK
  5730.       ELSE IF (STATE .EQ. E) THEN
  5731.          CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
  5732.          ENDTIM = HR * 3600 + MIN * 60 + SEC
  5733.          SEND = ERROR
  5734.          IF (FFD .NE. CLOSED) CALL FCLOSE(FFD)
  5735.       ELSE IF (STATE .EQ. A) THEN
  5736.          CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
  5737.          ENDTIM = HR * 3600 + MIN * 60 + SEC
  5738.          SEND = ERROR
  5739.          IF (FFD .NE. CLOSED) CALL FCLOSE(FFD)
  5740.          CALL GETEMSG(ERRMSG(15))
  5741.          CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
  5742.       ELSE
  5743.          CALL DISPLA(' SEND - STATE ERROR = ',STATE)
  5744.          SEND = ERROR
  5745.          IF (FFD .NE. CLOSED) CALL FCLOSE(FFD)
  5746.       ENDIF
  5747.  
  5748.  
  5749.       RETURN
  5750.       END
  5751.       INTEGER FUNCTION SEOF()
  5752.  
  5753. ***   SEOF - SEND AN EOF PACKET AND WAIT FOR THE REPLY.
  5754. *
  5755.  
  5756.       IMPLICIT INTEGER (A-Z)
  5757.       PARAMETER (COMLIS = 0)
  5758.  
  5759. *CALL COMCKER
  5760.  
  5761.       CHARACTER LFN*10
  5762.  
  5763. *     HAVE WE TRIED THIS TOO MANY TIMES?
  5764.  
  5765.       IF (NUMTRY .GT. MAXRTRY) THEN
  5766.          SEOF = A
  5767.          ABORTYP = TOOMANY.OR.SENDING.OR.EOFERR
  5768.          RETURN
  5769.       ENDIF
  5770.       NUMTRY = NUMTRY + 1
  5771.  
  5772. *     SEND THE EOF PACKET
  5773.  
  5774.       CALL SNDPACK(Z,PACKNUM,0,0)
  5775.  
  5776. *     READ THE REPLY
  5777.  
  5778.       PTYP = RDPACK(LEN,NUM,RECPACK)
  5779.  
  5780. *     N A K
  5781.  
  5782.       IF (PTYP .EQ. N) THEN
  5783.          IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
  5784.             SEOF = STATE
  5785.             RETURN
  5786.          ELSE
  5787.             PTYP = Y
  5788.             NUM = NUM-1
  5789.          ENDIF
  5790.       ENDIF
  5791.  
  5792. *     A C K
  5793.  
  5794.       IF (PTYP .EQ. Y) THEN
  5795.          IF (PACKNUM .NE. NUM) THEN
  5796.             SEOF = STATE
  5797.             RETURN
  5798.          ENDIF
  5799.          NUMTRY = 0
  5800.          PACKNUM = MOD(PACKNUM+1,64)
  5801.          CALL FCLOSE(FFD)
  5802.  
  5803. *     GET NEXT FILE TO SEND, IF ANY.
  5804.  
  5805.          IF(LOCFILE) THEN
  5806.             CALL GETLFN(LFN)
  5807.          ELSE
  5808.             CALL REMOVE(FILESTR)
  5809.             CALL GETPFN(LFN)
  5810.          ENDIF
  5811.          IF(LFN .NE. ' ') THEN
  5812.             IF(.NOT.LOCFILE) CALL GETPFIL(LFN)
  5813.             CALL DPC2AS(LFN, FILESTR, INDEX(LFN,' ')-1)
  5814.             SEOF = F
  5815.          ELSE
  5816.             SEOF = B
  5817.          ENDIF
  5818.  
  5819. *     E R R O R
  5820.  
  5821.       ELSE IF (PTYP .EQ. E) THEN
  5822.          SEOF = E
  5823.          RETURN
  5824.  
  5825. *     B A D   C H E C K S U M
  5826.  
  5827.       ELSE IF (PTYP .EQ. ERROR) THEN
  5828.          SEOF = STATE
  5829.  
  5830. *     B A D   T Y P E
  5831.  
  5832.       ELSE
  5833.          SEOF = A
  5834.          ABORTYP = INVALID.OR.SENDING.OR.EOFERR
  5835.  
  5836.       ENDIF
  5837.  
  5838.  
  5839.       RETURN
  5840.       END
  5841.           IDENT  SETF
  5842.           ENTRY  SETF
  5843.           B1=1
  5844.           TITLE  SETF - SET SPECIAL HANDLING FOR TERMINAL OUTPUT FILE.
  5845.           COMMENT SETF - SET SPECIAL HANDLING FOR TERMINAL OUTPUT FILE.
  5846.           SPACE  4
  5847. ***       SETF - SET SPECIAL HANDLING FOR TERMINAL OUTPUT FILE.
  5848. *
  5849. *         FORTRAN CALL -
  5850. *
  5851. *            CALL SETF(FET)
  5852. *
  5853. *         ENTRY  (FET) = FET OF TERMINAL OUTPUT FILE.
  5854. *
  5855. *         EXIT   NONE.
  5856.  
  5857.  
  5858.  SETF     SUBR               ENTRY/EXIT
  5859.           SA2    X1+B1       (X2) = FET+1
  5860.           SX6    B1
  5861.           LX6    36
  5862.           BX6    X6+X2       SET FLUSH BIT
  5863.           SA6    A2
  5864.           SA2    X1          (X2) = FET+0
  5865.           MX6    42
  5866.           BX6    X6*X2       (X6) = FILE NAME
  5867.           BX6    X6+X1       COMBINE WITH FET ADDRESS
  5868.           SA6    2
  5869.           MX6    0
  5870.           SA6    A6+B1
  5871.           EQ     SETFX       RETURN
  5872.  
  5873.           END
  5874.       SUBROUTINE SETPACK(ATTR)
  5875.  
  5876. ***   SETPACK - SET PACKET SEND OR RECEIVE ATTRIBUTES.
  5877. *
  5878. *     SETPACK WILL WET THE ATTRIBUTES OF THE PASSED ATTRIBUTE
  5879. *     LIST.  THIS SUBROUTINE WILL SET THE APPROPRIATE PACKET
  5880. *     PARAMETER.  THE PARAMETER TO SET IS PASSED IN AN ARRAY
  5881. *     AND IS VERY ORDER DEPENDENT.  SEE COMMON BLOCK /PACKET/
  5882. *     FOR THE ORDERING.  NOTE THAT SEND AND RECEIVE PARAMETER
  5883. *     ORDERING AND STORAGE SIZE IN THE COMMON BLOCK ARE
  5884. *     IDENTICAL.  KEEP IT THAT WAY!
  5885.  
  5886.       IMPLICIT INTEGER (A-Z)
  5887.       PARAMETER (COMLIS = 0)
  5888.  
  5889. *CALL COMCKER
  5890.  
  5891.       INTEGER ATTR(12)
  5892.       PARAMETER (TSIZE=9)
  5893.       CHARACTER*15 ATTRTYP(TSIZE)
  5894.       DATA ATTRTYP / 'END-OF-LINE', 'PACKET-LENGTH', 'PAD-CHARACTER',
  5895.      +               'PAD-LENGTH', 'QUOTE-CHARACTER', 'Q8-CHARACTER',
  5896.      +               'REPEAT-PREFIX','SYNC-CHARACTER', 'TIME-OUT' /
  5897.  
  5898.  
  5899.       INDX = MATCH(ATTRTYP,TSIZE,.FALSE.)
  5900.       IF (INDX .LE. 0) RETURN
  5901.       GO TO (10, 20, 30, 40, 50, 55, 56, 60, 70), INDX
  5902.  
  5903. *     SET EOL CHARACTER
  5904.  
  5905.  10   CALL SETVAL(ATTR(5),'I',1,31,127,127,HLPASCH,.TRUE.)
  5906.       RETURN
  5907.  
  5908. *     SET MAXIMUM PACKET LENGTH
  5909.  
  5910.  20   CALL SETVAL(ATTR(1),'I',20,LPKSIZE,20,LPKSIZE,HLPPLEN,.TRUE.)
  5911.       RETURN
  5912.  
  5913. *     SET PAD CHARACTER
  5914.  
  5915.  30   CALL SETVAL(ATTR(4),'I',0,31,127,127,HLPASCH,.TRUE.)
  5916.       RETURN
  5917.  
  5918. *     SET PAD LENGTH
  5919.  
  5920.  40   CALL SETVAL(ATTR(3),'I',0,94,0,94,HLPPADL,.TRUE.)
  5921.       RETURN
  5922.  
  5923. *     SET CONTROL QUOTE CHARACTER
  5924.  
  5925.  50   CALL SETVAL(ATTR(6),'I',33,62,96,126,HLPASCH,.TRUE.)
  5926.       RETURN
  5927.  
  5928. *     SET EIGHT BIT QUOTE CHARACTER
  5929.  
  5930.  55   CALL SETVAL(ATTR(7),'I',33,62,96,126,HLPASCH,.TRUE.)
  5931.       RETURN
  5932.  
  5933. *     SET REPEAT PREFIX CHARACTER
  5934.  
  5935.  56   CALL SETVAL(ATTR(9),'I',33,62,96,126,HLPASCH,.TRUE.)
  5936.       RETURN
  5937.  
  5938. *     SET SYNC CHARACTER
  5939.  
  5940.  60   CALL SETVAL(ATTR(12),'I',0,127,0,127,HLPASCH,.TRUE.)
  5941.       RETURN
  5942.  
  5943. *     SET TIMEOUT VALUE
  5944.  
  5945.  70   CALL SETVAL(ATTR(2),'I',0,94,0,94,HLPTIMO,.TRUE.)
  5946.       RETURN
  5947.  
  5948.  
  5949.       END
  5950.       SUBROUTINE SETVAL(VAR,VTYP,MN1,MX1,MN2,MX2,HLPMSG,CONFRM)
  5951.  
  5952. ***   SETVAL - SET A VARIABLE VALUE.
  5953. *
  5954. *     SETVAL WILL READ A TOKEN FROM INPUT AND SET A VARIABLE TO
  5955. *     THAT VALUE.  IF THE TOKEN IS A QUESTION MARK THEN THE
  5956. *     HELP MESSAGE WILL BE DISPLAYED AND SETVAL WILL RETURN
  5957. *     WITHOUT SETTING A VALUE.
  5958. *
  5959. *     ENTRY:   (VTYP) = CHARACTER 'S' FOR STRING VARIABLE.
  5960. *                     = CHARACTER 'I' FOR INTEGER VARIABLE.
  5961. *              (MN1-MX1) = RANGE #1 FOR VAR TO FIT IN IF INTEGER.
  5962. *                        = MN1 IS RETURN CODE FOR ERROR AND MX1 IS
  5963. *                          MAX SIZE OF STRING IF STRING VAR.
  5964. *              (MN2-MX2) = SECONDARY RANGE FOR VAR TO FIT IN IF
  5965. *                          INTEGER VAR.
  5966. *                        = UNUSED FOR STRING VAR.
  5967. *              (HLPMSG) = FPRINTF MESSAGE FORMAT TO DISPLAY IF
  5968. *                         A QUESTION MARK IS READ.
  5969. *
  5970. *     EXIT:    (VAR) = INT VALUE READ IF INTEGER VAR. OR STRING
  5971. *                      VALUE READ IF STRING VAR.
  5972.  
  5973.       IMPLICIT INTEGER (A-Z)
  5974.       PARAMETER (COMLIS = 0)
  5975.  
  5976. *CALL COMCKER
  5977.  
  5978.       CHARACTER*(*) VTYP, HLPMSG
  5979.       INTEGER VAR(41), STR(41)
  5980.       LOGICAL CONFRM, CONFIRM
  5981.  
  5982.  
  5983. *     CHECK VAR TYPE
  5984.  
  5985.       IF (VTYP .NE. 'S' .AND. VTYP .NE. 'I') THEN
  5986.          CALL DISPLA('SETVAL - INVALID VAR TYPE ',ASC(VTYP))
  5987.          CALL ABORT
  5988.       ENDIF
  5989.       IF (VTYP .EQ. 'S' .AND. MX1 .GT. 40) THEN
  5990.          CALL DISPLA('SETVAL - STRING MAX IS TOO LARGE ',MX1)
  5991.          CALL ABORT
  5992.       ENDIF
  5993.       LEN = GETWORD(CMDFD,STR,MX1)
  5994.       IF (LEN .EQ. 0 .OR. LEN .EQ. EOF) THEN
  5995.          IF (VTYP .EQ. 'I') THEN
  5996.             CALL FPRINTF(STDOUT,'?^INVALID, ^FIRST NONSPACE CHARACTER IS
  5997.      - NOT A DIGIT\N',0,0)
  5998.          ELSE
  5999.             CALL FPRINTF(STDOUT,'?^INVALID, ^MISSING PARAMETER\N',0,0)
  6000.             MN1 = ERROR
  6001.          ENDIF
  6002.          RETURN
  6003.       ENDIF
  6004.       IF (STR(1) .EQ. QMARK) THEN
  6005.          CALL FPRINTF(STDOUT,HLPMSG,0,0)
  6006.          CALL FFLUSH(CMDFD)
  6007.          IF (VTYP .EQ. 'S') MN1 = ERROR
  6008.          RETURN
  6009.       ENDIF
  6010.  
  6011. *     CONFIRM THE REQUEST IF NECESSARY
  6012.  
  6013.       IF (CONFRM) THEN
  6014.          IF (.NOT. CONFIRM(CMDFD)) THEN
  6015.             IF (VTYP .EQ. 'S') MN1 = ERROR
  6016.             RETURN
  6017.          ENDIF
  6018.       ENDIF
  6019.  
  6020. *     GO AHEAD AND SET THE VARIABLE
  6021.  
  6022.       IF (VTYP .EQ. 'I') THEN
  6023.          I = CTOI(STR)
  6024.          IF (I .GE. MN1 .AND. I .LE. MX1) THEN
  6025.             VAR(1) = I
  6026.          ELSE IF (I .GE. MN2 .AND. I .LE. MX2) THEN
  6027.             VAR(2) = I
  6028.          ELSE
  6029.             CALL FPRINTF(STDOUT,'?^VALUE IS NOT WITHIN RANGE OF @D - @D'
  6030.      +        ,MN1,MX1)
  6031.             IF (MN1 .NE. MN2 .OR. MX1 .NE. MX2) THEN
  6032.                CALL FPRINTF(STDOUT,' OR @D - @D',MN2,MX2)
  6033.             ENDIF
  6034.             CALL PUTC(NEL,STDOUT)
  6035.          ENDIF
  6036.       ELSE
  6037.          DO 100 I = 1,LEN
  6038.             VAR(I) = STR(I)
  6039. 100      CONTINUE
  6040.          VAR(LEN+1) = 0
  6041.          MN1 = OK
  6042.       ENDIF
  6043.  
  6044.  
  6045.       RETURN
  6046.       END
  6047.       INTEGER FUNCTION SFILE(SENDTYP, STR)
  6048.  
  6049. ***   SFILE - SEND A FILENAME PACKET AND WAIT FOR REPLY.
  6050. *
  6051. *     THE FILENAME IS ASSUMED TO HAVE BEEN PREVIOUSLY OBTAINED
  6052. *     AND STORED IN THE ASCII STRING BUFFER FILESTR IN UPPER CASE.
  6053. *
  6054. *     ENTRY:   SENDTYP - F OR X SEND TYPE FOR 'SFILE'
  6055. *              STR - CHARACTER MESSAGE STRING IF X TYPE SEND
  6056. *
  6057. *     F TYPE SEND IS FOR NORMAL FILE TRANSFER.
  6058. *     X TYPE SEND ALLOWS TEXT TRANSFER TO THE REMOTE KERMIT WITH A
  6059. *     HEADER TEXT STRING.
  6060. *
  6061.  
  6062.       IMPLICIT INTEGER (A-Z)
  6063.       PARAMETER (COMLIS = 0)
  6064.  
  6065. *CALL COMCKER
  6066.  
  6067.       CHARACTER STR*(*)
  6068.       CHARACTER FILENAM*10
  6069.  
  6070. *     HAVE WE TRIED THIS TOO MANY TIMES?
  6071.  
  6072.       IF (NUMTRY .GT. MAXRTRY) THEN
  6073.          SFILE = A
  6074.          ABORTYP = TOOMANY.OR.SENDING.OR.FILERR
  6075.          RETURN
  6076.       ENDIF
  6077.       NUMTRY = NUMTRY + 1
  6078.  
  6079. *     SEND THE FILENAME PACKET
  6080.  
  6081.  
  6082. *     OPEN FILE ON FIRST TRY OF 'F' PACKET SEND.
  6083.  
  6084.       IF(NUMTRY .EQ. 1) THEN
  6085.          CALL AS2DPC(FILESTR,FILENAM)
  6086.          IF (FILMODE .EQ. TEXT) THEN
  6087.             FFD = FOPEN(FILENAM,RD,TXTMODE)
  6088.          ELSE
  6089.             FFD = FOPEN(FILENAM,RD,CSBIN)
  6090.          ENDIF
  6091.          IF (FFD .EQ. ERROR) THEN
  6092.             SINIT = A
  6093.             FFD = CLOSED
  6094.             RETURN
  6095.          ENDIF
  6096.       ENDIF
  6097.       IF(SENDTYP .EQ. F) THEN
  6098.          CALL SNDPACK(F,PACKNUM,SLEN(FILESTR),FILESTR)
  6099.       ELSE
  6100.          CALL DPC2AS(STR, RECPACK, LEN(STR))
  6101.          CALL SNDPACK(X, PACKNUM, LEN(STR), RECPACK)
  6102.       ENDIF
  6103.  
  6104. *     READ THE REPLY
  6105.  
  6106.       PTYP = RDPACK(I, NUM, RECPACK)
  6107.  
  6108. *     N A K
  6109.  
  6110.       IF (PTYP .EQ. N) THEN
  6111.          IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
  6112.             SFILE = STATE
  6113.             RETURN
  6114.          ELSE
  6115.             PTYP = Y
  6116.             NUM = NUM-1
  6117.          ENDIF
  6118.       ENDIF
  6119.  
  6120. *     A C K
  6121.  
  6122.       IF (PTYP .EQ. Y) THEN
  6123.          IF (PACKNUM .NE. NUM) THEN
  6124.             SFILE = STATE
  6125.             RETURN
  6126.          ENDIF
  6127.          NUMTRY = 0
  6128.          PACKNUM = MOD(PACKNUM+1,64)
  6129.  
  6130. *        GET FIRST PACKET OF DATA FROM THE FILE
  6131.  
  6132.          PSIZE = BUFFILL(FFD,PACKET)
  6133.          SFILE = D
  6134.  
  6135. *     E R R O R
  6136.  
  6137.       ELSE IF (PTYP .EQ. E) THEN
  6138.          SFILE = E
  6139.          RETURN
  6140.  
  6141. *     B A D   C H E C K S U M
  6142.  
  6143.       ELSE IF (PTYP .EQ. ERROR) THEN
  6144.          SFILE = STATE
  6145.  
  6146. *     B A D   T Y P E
  6147.  
  6148.       ELSE
  6149.          SFILE = A
  6150.          ABORTYP = INVALID.OR.SENDING.OR.FILERR
  6151.  
  6152.       ENDIF
  6153.  
  6154.  
  6155.       RETURN
  6156.       END
  6157.       INTEGER FUNCTION SINIT()
  6158.  
  6159. ***   SINIT - SEND THE SEND-INIT PACKET AND WAIT FOR REPLY.
  6160. *
  6161. *     ASSUMES FILESTR HAS ALREADY BEEN CHECKED FOR LEGAL FILENAME
  6162. *     AND BEING LOCAL.
  6163.  
  6164.       IMPLICIT INTEGER (A-Z)
  6165.       PARAMETER (COMLIS = 0)
  6166.  
  6167. *CALL COMCKER
  6168.  
  6169. *     CHECK NUMBER OF RETRIES
  6170.  
  6171.       IF (NUMTRY .GT. MAXRINI) THEN
  6172.          SINIT = A
  6173.          ABORTYP = TOOMANY.OR.SENDING.OR.INITERR
  6174.          RETURN
  6175.       ELSE
  6176.          NUMTRY = NUMTRY + 1
  6177.       ENDIF
  6178.  
  6179. *     SEND THE SEND-INIT PACKET
  6180.  
  6181.       CALL SNDPAR(S,PACKET,LEN)
  6182.       CALL SNDPACK(S,PACKNUM,LEN,PACKET)
  6183.  
  6184. *     READ AND PROCESS THE REPLY
  6185.  
  6186.       PTYP = RDPACK(LEN,NUM,RECPACK)
  6187.  
  6188. *     N A K
  6189.  
  6190.       IF (PTYP .EQ. N) THEN
  6191.          SINIT = STATE
  6192.          RETURN
  6193.  
  6194. *     A C K
  6195.  
  6196.       ELSE IF (PTYP .EQ. Y) THEN
  6197.          IF (PACKNUM .NE. NUM) THEN
  6198.             SINIT = STATE
  6199.             RETURN
  6200.          ENDIF
  6201.          CALL RDPARAM(RECPACK)
  6202.  
  6203. *        CONVERT Q8CH FOR EASIER USE LATER ON IN ENCODING FILE DATA.
  6204. *        ANY RESPONSE TO OUR "Y" THAT IS NOT A VALID EIGHT-BIT QUOTE
  6205. *        CHARACTER WILL CAUSE EIGHT-BIT QUOTING TO BE SUPPRESSED.
  6206.  
  6207.          IF ((R8QUOTE .LT. 33 .OR.  R8QUOTE .GT. 126) .OR.
  6208.      -       (R8QUOTE .GT. 62 .AND. R8QUOTE .LT. 96)) THEN
  6209.             Q8CH = 0
  6210.          ELSE
  6211.             Q8CH = R8QUOTE
  6212.          ENDIF
  6213.  
  6214.          NUMTRY = 0
  6215.          PACKNUM = MOD(PACKNUM+1,64)
  6216.          SINIT = F
  6217.  
  6218. *     E R R O R
  6219.  
  6220.       ELSE IF (PTYP .EQ. E) THEN
  6221.          SINIT = E
  6222.          RETURN
  6223.  
  6224. *     B A D  C E C K S U M
  6225.  
  6226.       ELSE IF (PTYP .EQ. ERROR) THEN
  6227.          SINIT = STATE
  6228.  
  6229. *     B A D  T Y P E
  6230.  
  6231.       ELSE
  6232.          SINIT = A
  6233.          ABORTYP = INVALID.OR.SENDING.OR.INITERR
  6234.  
  6235.       ENDIF
  6236.  
  6237.  
  6238.       RETURN
  6239.       END
  6240.       SUBROUTINE SLEEP(SECONDS)
  6241.  
  6242. ***   SLEEP - DELAY A NUMBER OF SECONDS
  6243. *
  6244. *     ENTRY   SECONDS = INTEGER NUMBER OF SECONDS TO SLEEP.
  6245. *
  6246. *     EXIT    INDICATED NUMBER OF SECONDS HAS ELAPSED.
  6247.  
  6248.       IMPLICIT INTEGER (A-Z)
  6249.       PARAMETER (COMLIS = 0)
  6250.  
  6251. *CALL COMCKER
  6252.  
  6253.  
  6254.       CALL ROLLOUT(O"0200 00 0000"+SECONDS)
  6255.  
  6256.  
  6257.       RETURN
  6258.       END
  6259.       INTEGER FUNCTION SLEN(STR)
  6260.  
  6261. ***   SLEN - RETURN THE LENGTH OF A ZERO TERMINATED ASCII STRING BUFFER.
  6262. *
  6263.  
  6264.       IMPLICIT INTEGER (A-Z)
  6265.       PARAMETER (COMLIS = 0)
  6266.  
  6267. *CALL COMCKER
  6268.  
  6269.       BOOLEAN STR(*)
  6270.  
  6271.  
  6272.       I = 0
  6273.  10   IF (STR(I+1) .NE. 0) THEN
  6274.          I = I+1
  6275.          GOTO 10
  6276.       ENDIF
  6277.       SLEN = I
  6278.  
  6279.  
  6280.       RETURN
  6281.       END
  6282.       SUBROUTINE SNDPACK(TYPE,NUM,LEN,DATA)
  6283.  
  6284. ***   SNDPACK - SEND A PACKET DOWN AN OUTPUT STREAM
  6285. *
  6286. *     SNDPACK WILL SEND A PACKET OF INFORMATION AND LOG IT
  6287. *     IF DEBUG IS TURNED ON.
  6288.  
  6289.       IMPLICIT INTEGER (A-Z)
  6290.       PARAMETER (COMLIS = 0)
  6291.  
  6292. *CALL COMCKER
  6293.  
  6294.       INTEGER DATA(*)
  6295.       LOGICAL LONGPAK
  6296.  
  6297. *CALL COMXKER
  6298.  
  6299.  
  6300. *     LOG THE PACKET
  6301.  
  6302.       IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
  6303.          CALL FPRINTF(DEBUGFD,'^S^E^N^D^I^N^G:\N')
  6304.       ENDIF
  6305.  
  6306. *     PUT OUT PAD CHARS
  6307.  
  6308.       DO 100 I = 1,RPADCT
  6309.          CALL PUTC(RPADCH,STDOUT)
  6310.          IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
  6311.             CALL PUTC(RPADCH,DEBUGFD)
  6312.          ENDIF
  6313.  100  CONTINUE
  6314.  
  6315. *     PACKET LEN ASSUMES ONE CHARACTER CHECKSUMS
  6316.  
  6317.       CALL PUTC(RSYNC,STDOUT)
  6318.  
  6319. *     DETERMINE IF WE NEED EXTENDED PACKET.
  6320. *     OUTPUT PROPER LENGTH FIELD, 0 IF EXTENDED PACKET
  6321.  
  6322.       LONGPAK = ((RPKSIZE.GT.IPKSIZE) .AND. (LEN.GT.91))
  6323.       IF(LONGPAK) THEN
  6324.          CHKSUM = TOCHAR(0)
  6325.       ELSE
  6326.          CHKSUM = TOCHAR(LEN+3)
  6327.       ENDIF
  6328.       CALL PUTC(CHKSUM,STDOUT)
  6329.       TMP = TOCHAR(NUM)
  6330.       CHKSUM = CHKSUM + TMP
  6331.       CALL PUTC(TMP,STDOUT)
  6332.       CHKSUM = CHKSUM + TYPE
  6333.       CALL PUTC(TYPE,STDOUT)
  6334.  
  6335. *     IF EXTENDED PACKET, OUTPUT EXTENDED HEADER BEFORE DATA
  6336.  
  6337.       IF(LONGPAK) THEN
  6338.          LENX1 = TOCHAR((LEN+1)/95)
  6339.          CHKSUM = CHKSUM + LENX1
  6340.          CALL PUTC(LENX1, STDOUT)
  6341.          LENX2 = TOCHAR(MOD(LEN+1, 95))
  6342.          CHKSUM = CHKSUM + LENX2
  6343.          CALL PUTC(LENX2, STDOUT)
  6344.          HCHKSUM = TOCHAR((CHKSUM + (CHKSUM.AND.O"300") / O"100")
  6345.      +                     .AND. O"77")
  6346.          CHKSUM = CHKSUM + HCHKSUM
  6347.          CALL PUTC(HCHKSUM, STDOUT)
  6348.       ENDIF
  6349.       DO 110 I = 1,LEN
  6350.          CHKSUM = CHKSUM + (DATA(I) .AND. O"377")
  6351.          CALL PUTC(DATA(I),STDOUT)
  6352. 110   CONTINUE
  6353.       CHKSUM = (CHKSUM + (CHKSUM.AND.O"300") / O"100") .AND. O"77"
  6354.       CALL PUTC(TOCHAR(CHKSUM),STDOUT)
  6355.       CALL PUTC(REOLCH,STDOUT)
  6356.       IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
  6357.          CALL PUTC(RSYNC,DEBUGFD)
  6358.          IF(LONGPAK) THEN
  6359.             CALL PUTC(TOCHAR(0), DEBUGFD)
  6360.          ELSE
  6361.             CALL PUTC(TOCHAR(LEN+3), DEBUGFD)
  6362.          ENDIF
  6363.          CALL PUTC(TOCHAR(NUM),DEBUGFD)
  6364.          CALL PUTC(TYPE,DEBUGFD)
  6365.          IF(LONGPAK) THEN
  6366.             CALL PUTC(LENX1, DEBUGFD)
  6367.             CALL PUTC(LENX2, DEBUGFD)
  6368.             CALL PUTC(HCHKSUM, DEBUGFD)
  6369.          ENDIF
  6370.          IF (LEN .GT. 0) CALL PUTSTR(DEBUGFD,DATA)
  6371.          CALL PUTC(TOCHAR(CHKSUM),DEBUGFD)
  6372.          CALL PUTC(REOLCH,DEBUGFD)
  6373.          CALL PUTC(NEL,DEBUGFD)
  6374.       ENDIF
  6375.  
  6376. *     ADD A NOS ZERO BYTE EOL AND FLUSH THE BUFFER
  6377. *     (NOTE: PUTC XORS THE HIGH BIT OF EACH 12 BIT BYTE FOR CONNECTED
  6378. *     FILES, SO TO GET A ZERO BYTE WE PUTC 4000B)
  6379.  
  6380.       CALL PUTC(O"4000",STDOUT)
  6381.       CALL FFLUSH(STDOUT)
  6382.  
  6383. *     UPDATE THE STATISTICS
  6384.  
  6385.       NCH = RPADCT+5+LEN+1
  6386.       IF(LONGPAK) THEN
  6387.          NCH = NCH + 3
  6388.       ENDIF
  6389.       SCHCNT = SCHCNT+NCH
  6390.       SCHOVRH = SCHOVRH+NCH-LEN
  6391.  
  6392.  
  6393.       RETURN
  6394.       END
  6395.       SUBROUTINE SNDPAR(TYPE,PDATA,LEN)
  6396.  
  6397. ***   SNDPAR - SET UP PARAMETERS TO SEND TO OTHER KERMIT.
  6398. *
  6399. *     ENTRY    (TYPE) = TYPE OF BLOCK WE ARE GENERATING PARAMETERS FOR.
  6400. *                     = *Y* IF AN ACK (REPLY) PACKET.
  6401. *                     = *S* IF A SEND-INIT (INITIAL) PACKET.
  6402. *
  6403. *     EXIT     (PDATA) = UNPACKED ASCII BUFFER WITH
  6404.  
  6405.       IMPLICIT INTEGER (A-Z)
  6406.       PARAMETER (COMLIS = 0)
  6407.  
  6408. *CALL COMCKER
  6409.  
  6410.       BOOLEAN PDATA(*)
  6411.  
  6412. *CALL COMXKER
  6413.  
  6414.  
  6415. *     SEND WHAT WE WANT
  6416.  
  6417.       PDATA(1)  = TOCHAR(MIN0(IPKSIZE, SPKSIZE))
  6418.       PDATA(2)  = TOCHAR(STIMOUT)
  6419.       PDATA(3)  = TOCHAR(SPADCT)
  6420.       PDATA(4)  = CTL(SPADCH)
  6421.       PDATA(5)  = TOCHAR(SEOLCH)
  6422.       PDATA(6)  = SCQUOTE
  6423.       PDATA(7)  = S8QUOTE
  6424.       PDATA(8)  = SCHKTYP
  6425.  
  6426.       IF (TYPE .EQ. Y) THEN
  6427.  
  6428. *        R8QUOTE HAS BEEN SET TO THE 8-BIT QUOTE CHARACTER FROM THE
  6429. *        THE SENDER'S SEND-INIT PACKET, OR IS *N* BY DEFAULT.
  6430. *        THE FOLLOWING DECISION IS MADE IN ORDER TO SET *Q8CH*
  6431. *        FOR LATER USE IN *BUFEMP* -
  6432. *
  6433. *        IF A Y, WE WILL SEND BACK THE CHARACTER WE WANT HIM TO USE
  6434. *        (I8QUOTE) AND PUT THAT CHARACTER IN Q8CH.
  6435. *
  6436. *        IF AN N, NO QUOTING WILL BE DONE, SO SET Q8CH = 0.
  6437. *
  6438. *        OTHERWISE, HE SENT US HIS QUOTE CHARACTER, SO AGREE TO IT
  6439. *        AND PUT THAT CHARACTER IN Q8CH.
  6440.  
  6441.          IF (R8QUOTE .EQ. Y) THEN
  6442.             PDATA(7) = I8QUOTE
  6443.             Q8CH = I8QUOTE
  6444.          ELSE IF (R8QUOTE .EQ. N) THEN
  6445.             PDATA(7) = N
  6446.             Q8CH = 0
  6447.          ELSE
  6448.             PDATA(7) = Y
  6449.             Q8CH = R8QUOTE
  6450.          ENDIF
  6451.  
  6452. *        SET THE REPEAT PREFIX AND ECHO WHAT THE SENDER REQUESTED
  6453. *
  6454. *        WE ALSO SET REPCH FOR LATER USE IN ROUTINE *BUFEMP*.
  6455.  
  6456.          PDATA(9) = RRPTPFX
  6457.          IF (RRPTPFX .EQ. BLANK) THEN
  6458.             REPCH = 0
  6459.          ELSE
  6460.             REPCH = RRPTPFX
  6461.          ENDIF
  6462.  
  6463. *        WE CAN TAKE EXTENDED PACKETS IF *SPKSIZE* ALLOWS.
  6464.  
  6465.          IF(SPKSIZE .GT. IPKSIZE) THEN
  6466.             PDATA(10) = TOCHAR(CAPAS5)
  6467.             PDATA(11) = TOCHAR(0)
  6468.             PDATA(12) = TOCHAR(SPKSIZE/95)
  6469.             PDATA(13) = TOCHAR(MOD(SPKSIZE,95))
  6470.             PDATA(14) = 0
  6471.             LEN = 13
  6472.          ELSE
  6473.             PDATA(10) = 0
  6474.             LEN = 9
  6475.          ENDIF
  6476.  
  6477.       ELSE
  6478.          PDATA(7)  = S8QUOTE
  6479.          PDATA(9)  = SRPTPFX
  6480.  
  6481. *        WE CAN SEND EXTENDED PACKETS IF *DPKSIZE* ALLOWS.
  6482.  
  6483.          IF(DPKSIZE .GT. IPKSIZE) THEN
  6484.             PDATA(10) = TOCHAR(CAPAS5)
  6485.             PDATA(11) = TOCHAR(0)
  6486.             PDATA(12) = TOCHAR(DPKSIZE/95)
  6487.             PDATA(13) = TOCHAR(MOD(DPKSIZE,95))
  6488.             PDATA(14) = 0
  6489.             LEN = 13
  6490.          ELSE
  6491.             PDATA(10) = 0
  6492.             LEN = 9
  6493.          ENDIF
  6494.  
  6495.       ENDIF
  6496.  
  6497.  
  6498.  
  6499.       RETURN
  6500.       END
  6501.       SUBROUTINE SPRINTF(STR,FMT,I1,I2,I3,I4)
  6502.  
  6503. ***   SPRINTF - POOR ATTEMPT AT DOING INTERNAL FORMATTED I/O.
  6504. *
  6505. *     SPRINTF IS THE SAME AS FPRINTF EXCEPT THAT IT WRITES TO
  6506. *     AND ASCII STRING BUFFER INSTEAD.
  6507.  
  6508.       IMPLICIT INTEGER (A-Z)
  6509.       PARAMETER (COMLIS = 0)
  6510.  
  6511. *CALL COMCKER
  6512.  
  6513.       CHARACTER*(*) FMT
  6514.       BOOLEAN STR(*)
  6515.  
  6516.  
  6517.       CALL DOPRNT(0,STR,2,FMT,I1,I2,I3,I4)
  6518.  
  6519.  
  6520.       RETURN
  6521.       END
  6522.       SUBROUTINE STRCPY(S1,S2)
  6523.  
  6524. ***   STRCPY - COPY ONE ASCII STRING TO ANOTHER
  6525. *
  6526.  
  6527.       IMPLICIT INTEGER (A-Z)
  6528.       PARAMETER (COMLIS = 0)
  6529.  
  6530. *CALL COMCKER
  6531.  
  6532.       BOOLEAN S1(*),S2(*)
  6533.  
  6534.  
  6535.       I1 = 1
  6536. 10    S2(I1) = S1(I1)
  6537.       IF (S1(I1) .NE. 0) THEN
  6538.          I1 = I1+1
  6539.          GOTO 10
  6540.       ENDIF
  6541.  
  6542.  
  6543.       RETURN
  6544.       END
  6545.       SUBROUTINE STTY(MODE,VALUE)
  6546.  
  6547. ***   STTY - SET A TERMINAL MODE.
  6548. *
  6549.  
  6550.       IMPLICIT INTEGER (A-Z)
  6551.       PARAMETER (COMLIS = 0)
  6552.  
  6553. *CALL COMCKER
  6554.  
  6555.       CHARACTER*(*) MODE
  6556.       INTEGER VALUE
  6557.  
  6558.  
  6559. *     DUPLEX (ECHOPLEX)
  6560.  
  6561.       IF (MODE .EQ. 'DUPLEX') THEN
  6562.          IF (VALUE .EQ. HALFDUP) THEN
  6563.             DUPLEX = HALFDUP
  6564.             FCHBUF(1,STDOUT) = O"0016 4061 4000 0000 0000"
  6565.          ELSE
  6566.             DUPLEX = FULLDUP
  6567.             FCHBUF(1,STDOUT) = O"0016 4061 4001 0000 0000"
  6568.          ENDIF
  6569.          FNWDS(STDOUT) = 1
  6570.          CALL FFLUSH(STDOUT)
  6571.  
  6572. *     RECEIVE-FILE-CONFIGURATION = ON
  6573.  
  6574.       ELSE IF (MODE .EQ. 'RCV-ON') THEN
  6575.          FCSET(STDIN) = CSTXP
  6576.          FCHBUF(1,STDOUT) = O"0016 4070 4001 4071 4017"
  6577.          FCHBUF(2,STDOUT) = O"4072 4376 4073 4015 4074"
  6578.          FCHBUF(3,STDOUT) = O"4000 4106 4001 4061 4000"
  6579.          FCHBUF(4,STDOUT) = O"4064 4001 4036 4007 4037"
  6580.          FCHBUF(5,STDOUT) = O"4370 0000 0000 0000 0000"
  6581.          FNWDS(STDOUT) = 5
  6582.          CALL FFLUSH(STDOUT)
  6583.  
  6584. *     RECEIVE-FILE-CONFIGURATION = OFF
  6585.  
  6586.       ELSE IF (MODE .EQ. 'RCV-OFF') THEN
  6587.          FCSET(STDIN) = CS612
  6588.          IF (VALUE .EQ. HALFDUP) THEN
  6589.             FCHBUF(1,STDOUT) = O"0016 4064 4000 0000 0000"
  6590.             FNWDS(STDOUT) = 1
  6591.          ELSE
  6592.             FCHBUF(1,STDOUT) = O"0016 4061 4001 4064 4000"
  6593.             FCHBUF(2,STDOUT) = O"0000 0000 0000 0000 0000"
  6594.             FNWDS(STDOUT) = 2
  6595.          ENDIF
  6596.          CALL FFLUSH(STDOUT)
  6597.  
  6598. *     INVALID MODE
  6599.  
  6600.       ELSE
  6601.          CALL DISPLA(' STTY - INVALID MODE ',BOOL(MODE))
  6602.          CALL ABORT
  6603.  
  6604.       ENDIF
  6605.  
  6606.  
  6607.       RETURN
  6608.       END
  6609.       SUBROUTINE TXTMCMD
  6610.  
  6611. ***   TXTMCMD - PERFORM A SET TEXT-MODE XXXX COMMAND
  6612. *
  6613.  
  6614.       IMPLICIT INTEGER (A-Z)
  6615.       PARAMETER (COMLIS = 0)
  6616.  
  6617. *CALL COMCKER
  6618.  
  6619.       LOGICAL CONFIRM
  6620.       PARAMETER (TSIZE=4)
  6621.       CHARACTER*10 MODETYP(TSIZE)
  6622.       DATA MODETYP / 'AUTO', 'DISPLAY', '6/12-ASCII', '8/12-ASCII'/
  6623.  
  6624. *     MATCH THE PARAMETER
  6625.  
  6626.       INDX = MATCH(MODETYP,TSIZE,.FALSE.)
  6627.       IF (INDX .LE. 0) RETURN
  6628.       IF (.NOT. CONFIRM(CMDFD)) RETURN
  6629.  
  6630. *     TAKE THE APPROPRIATE ACTION
  6631.  
  6632.       GO TO (10, 20, 30, 40), INDX
  6633.  
  6634. *     SET AUTO
  6635.  
  6636.  10   TXTMODE = CSNONE
  6637.       RETURN
  6638.  
  6639. *     SET DISPLAY CODE
  6640.  
  6641.  20   TXTMODE = CSDSP
  6642.       RETURN
  6643.  
  6644. *     SET 6/12 ASCII
  6645.  
  6646.  30   TXTMODE = CS612
  6647.       RETURN
  6648.  
  6649. *     SET 8/12 ASCII
  6650.  
  6651.  40   TXTMODE = CS812
  6652.       RETURN
  6653.  
  6654.       END
  6655.       SUBROUTINE UNGETC(FD,CH)
  6656.  
  6657. ***   UNGETC - PUT A CHARACTER BACK INTO THE INPUT STREAM.
  6658. *
  6659. *     UNGETC CAN ONLY PUT BACK A SINGLE CHARACTER.
  6660.  
  6661.       IMPLICIT INTEGER (A-Z)
  6662.       PARAMETER (COMLIS = 0)
  6663.  
  6664. *CALL COMCKER
  6665.  
  6666.  
  6667.       FUNGTCH(FD) = CH
  6668.  
  6669.  
  6670.       RETURN
  6671.       END
  6672.           IDENT  UVAMISC
  6673.           TITLE  UVAMISC - MISCELANEOUS NOS HELPER ROUTINES
  6674.           COMMENT  UVAMISC - MISCELANEOUS NOS HELPER ROUTINES
  6675.           B1=1
  6676.           SST
  6677.  UVAMISC  SPACE  4,10
  6678. ***       UVAMISC - MISCELANEOUS NOS HELPER ROUTINES.
  6679. *
  6680. *         MISCELLANEOUS ROUTINES REQUIRED FOR USE OF KERMIT UNDER NOS.
  6681.           SPACE  3
  6682.           USE /BMESAGE/      BOOLEAN MESSAGE TEXT COMMON BLOCK
  6683.  DATE8    MICRO  2,8,$"DATE"$
  6684.  VERSDAT  DATA   10H("DATE8") VERSION ASSEMBLE DATE
  6685.  VERSSTR  BSS    11           STRING VERSION OF ABOVE
  6686.           USE    *
  6687.  USTART   SPACE  4,10
  6688.           ENTRY  USTART
  6689. ***       USTART - INITIALIZE TERMINAL PARAMETERS.
  6690. *
  6691. *         ENTRY  NONE.
  6692. *
  6693. *         EXIT   (X6) = 0 IF JOB IS *IAOT*.
  6694.  
  6695.  USTART   SUBR               ENTRY/EXIT
  6696.           CSET   ASCII
  6697.           PROMPT OFF
  6698.           GETJO  EXITFLG
  6699.           SA1    EXITFLG
  6700.           SX6    X1-IAOT
  6701.           EQ     USTARTX     RETURN
  6702.  NODROP   SPACE  4,10
  6703.           ENTRY  NODROP
  6704. ***       NODROP - SET FILE STATUS TO AUTO-DROP.
  6705. *
  6706. *         SET AUTO-DROP STATUS ON A FILE.  THIS CLEARS SSST STATUS
  6707. *         WHICH IS SET FOR EVERY FILE CREATED BY AN SSJ= BLOCK PROGRAM.
  6708. *         SSST CAUSES FILES TO BE DROPPED AT END OF JOB STEP.
  6709. *
  6710. *         ENTRY  (X1) = FWA OF FET.
  6711. *
  6712. *         EXIT   NONE.
  6713.  
  6714.  NODROP   SUBR               ENTRY/EXIT
  6715.           BX5    X1
  6716.           SETFS  X5,AD
  6717.           EQ     NODROPX     RETURN
  6718.  MFS>     SPACE  4,10
  6719.           ENTRY  MFS>
  6720. ***       MFS> - MAKEFET HELPER.
  6721. *
  6722. *         ENTRY  (X1) = SOURCE ADDRESS.
  6723. *                (B6) = DESTINATION ADDRESS.
  6724. *
  6725. *         EXIT   NONE.
  6726.  
  6727.  MFS>     SUBR               ENTRY/EXIT
  6728.           SA1    X1
  6729.           BX6    X1
  6730.           SA6    B6
  6731.           SB6    B6+1        REQUIRED BY MAKEFET
  6732.           EQ     MFS>X       RETURN
  6733.  BTZ>     SPACE  4,10
  6734.           ENTRY  BTZ>
  6735. ***       BTZ> - CONVERT BLANKS TO ZEROS.
  6736. *
  6737. *         ENTRY  (X1) = WORD TO CONVERT.
  6738. *
  6739. *         EXIT   (X6) = CONVERTED WORD.
  6740.  
  6741.  BTZ>     SUBR               ENTRY/EXIT
  6742.           SB1    1
  6743.           SA2    =10H
  6744.           BX4    X1          SAVE INPUT WORD
  6745.           SA2    =10H
  6746.           BX1    X1-X2       CONVERT BANKS TO ZEROS
  6747.           RJ     =XZTB=      (X7) = MASK WITH 77B IN NON-BLANKS
  6748.           BX6    X7*X4
  6749.           EQ     BTZ>X       RETURN
  6750.  RETFILE  SPACE  4,10
  6751.           ENTRY  RETFILE
  6752. ***       RETFILE - RETURN A FILE.
  6753. *
  6754. *         ENTRY  (X1) = FWA OF FILE NAME.
  6755. *
  6756. *         EXIT   NONE.
  6757.  
  6758.  RETFILE  SUBR               ENTRY/EXIT
  6759.           SA1    X1          LFN
  6760.           RJ     BTZ>
  6761.           SX1    B1
  6762.           BX6    X6+X1
  6763.           SA6    FET
  6764.           RETURN FET,R
  6765.           EQ     RETFILEX    RETURN
  6766.  
  6767.  FET      FILEB  RETFILE,1   DUMMY FET
  6768.  WAITINP  SPACE  4,8
  6769.  
  6770. ***       LOGICAL FUNCTION WAITINP(ITIME)
  6771. *
  6772. *         ROUTINE WAITS FOR UP TO *ITIME* SECONDS FOR INPUT TO BE
  6773. *         ENTERED AT THE TERMINAL. RETURNS .FALSE. IF ROUTINE TIMES OUT.
  6774. *
  6775.           ENTRY  WAITINP
  6776.  
  6777.  WAITMS   =      25          WAIT INCREMENT, IN MILLISECONDS.
  6778.  NOSLVL   =      "NOSLVL"    OPERATING SYSTEM LEVEL, FROM NOSTEXT.
  6779.  
  6780.  WAITINP  EQ     *+40000B
  6781.           SB1    1
  6782.           SX2    1000        CONVERT TO MILLISECONDS
  6783.           SA1    X1          GET TIMER VALUE
  6784.           IX1    X1*X2
  6785.           SX2    WAITMS
  6786.           IX5    X1/X2       CHECK/WAIT LOOP COUNTER
  6787.  
  6788.  WAIT1    WAIT   WAITMS      WAIT A BIT BEFORE CHECKING
  6789.           IFGE   NOSLVL,602,1      OLD SYSTEMS DON'T HAVE THIS.
  6790.           SYSTEM TLX,R,WAITA,1600B  CHECK TYPE-AHEAD BUFFER
  6791.           SA1    WAITA
  6792.           SX5    X5-1
  6793.           MX6    59          FLAG TRUE
  6794.           NZ,X1  WAITINP     GOT INPUT, RETURN
  6795.           PL,X5  WAIT1       TRY AGAIN
  6796.           MX6    0
  6797.           EQ     WAITINP     TIMED OUT
  6798.  
  6799.  WAITA    CON    1           TYPE-AHEAD PRESENT FLAG (TRUE FOR PRE-602)
  6800.  SX12A8   SPACE  4,10
  6801.           ENTRY  SX12A8
  6802.           ENTRY  DPCA8
  6803. ***       SX12A8 - CONVERT 6/12 TO 8/12.
  6804. *         DPCA8 - CONVERT DISPLAY CODE TO 8/12.
  6805. *
  6806. *         CONVERT THE 6/12 ASCII DATA IN THE SOURCE WSA (SWSA) TO
  6807. *         8/12 ASCII IN THE DESTINATION WSA (DWSA), STOPPING AT
  6808. *         AN EOL OR THE END OF SWSA OR END OF DWSA.
  6809. *         IT IS ASSUMED THAT SWSA AND DWSA ARE THE SAME LENGTH,
  6810. *         FOR SIMPLICITY.  IN FACT, THE CALLER MUST INSURE THIS.
  6811. *         TWO WORDS FROM THE WSA ARE MANIPULATED AT ONCE.
  6812. *         WD1 IS READ FIRST, FOLLOWED BY WD2.  IF WD2 IS ZERO,
  6813. *         THEN A COLON AS THE LAST CHARACTER OF WD1 INDICATES A 66-BIT E
  6814. *         WHEN WD1 HAS BEEN PROCESSED, WD2 REPLACES IT AND A NEW WD2
  6815. *         IS READ FROM THE WSA.
  6816. *         ON ENTRY, STATUS CONTAINS A READC
  6817. *         RETURN CODE - 0 FOR TRANSFER COMPLETE (1 LINE READ
  6818. *         OR, APPARENTLY, WSA FULL), NEGATIVE IF EOF/EOI, LWA+1
  6819. *         OF DATA IF EOR. READC GUARANTEES AN EOL BYTE EVEN
  6820. *         IF DATA IN THE LAST BYTE OF THE WSA MUST BE CLOBBERED.
  6821. *         ON EXIT, STATUS=0 IF IT WAS ZERO ON ENTRY, OTHERWISE
  6822. *         LWA+1 OF DATA IN DWSA.  IF DWSA IS FILLED COMPLETELY,
  6823. *         AN EOL BYTE IS NOT GUARANTEED.
  6824. *
  6825. *         CALL SX12A8(SWSA,DWSA,WSAL,STATUS)
  6826. *
  6827. *         THE CALLING SEQUENCE FOR *DPCA8* IS THE SAME, BUT A DIFFERENT
  6828. *         CONVERSION TABLE IS USED.
  6829. *
  6830. *         REGISTER ASSIGNMENTS -
  6831. *
  6832. *         B2     ESCFLAG (74 OR 76 ESCAPE TABLE ADDRESS)
  6833. *         B3     CT (CHARACTER COUNTER)
  6834. *         B4     OUT12 BYTE SHIFT COUNT
  6835. *         B5     ADDRESS FOR NEXT WORD IN DWSA
  6836. *         B6     LWA+1 OF DWSA
  6837. *         X1     WD1
  6838. *         X2     WD2
  6839. *         A2     ADDRESS OF WD2
  6840. *         X4     OUT12 WORD UNDER CONSTRUCTION
  6841. *
  6842. *
  6843. *
  6844. *         CHARACTER TRANSLATION TABLES.
  6845. *
  6846.           USE    /CHARCOM/
  6847. ASC612    BSS    128
  6848. DPCTBL    BSS    128
  6849. LASCII    BSS    64
  6850. SX1274    BSS    64
  6851. SX1276    BSS    64
  6852. UASCII    BSS    64
  6853.           USE    *
  6854.  
  6855. SX12A8    SUBR               ENTRY/EXIT
  6856.           SB2    B0          PRESET ESCFLAG FOR 6/12 CONVERSION
  6857.           RJ     SXXXA8      PERFORM CONVERSION
  6858.           EQ     SX12A8X     RETURN
  6859.  
  6860.  DPCA8    SUBR               ENTRY/EXIT
  6861.           SB2    UASCII      PRESET ESCFLAG FOR DPC CONVERSION
  6862.           RJ     SXXXA8      PERFORM CONVERSION
  6863.           EQ     DPCA8       RETURN
  6864.  
  6865.  
  6866.  SXXXA8   PS                 INTERNAL ENTRY/EXIT
  6867.           SB1    1
  6868.           MX6    0
  6869.           SA6    EXITFLG
  6870.           BX7    X1          SAVE FWA OF SWSA FOR A MOMENT
  6871.           SA1    A1+B1
  6872.           SB5    X1          FWA OF DWSA
  6873.           SA1    A1+B1
  6874.           SA2    X1          LENGTH OF SWSA/DWSA
  6875.           BX6    X2
  6876.           SX6    X6-1
  6877.           SA6    SWSAREM     INITIALIZE WORDS REMAINING -1
  6878.           SB6    X2+B5       SET LWA+1 OF DWSA
  6879.           SA1    A1+B1
  6880.           BX6    X1
  6881.           SA6    STATADR     ADDRESS OF STATUS PARAMETER
  6882.           SA2    X7          A2=SOURCE WORD ADDRESS
  6883.           BX1    X2          X1=FIRST WD1
  6884.           SB4    48          OUT12 SHIFT COUNT
  6885.           MX4    0           OUT12 ACCUMULATOR
  6886.           SA3    X6          STATUS
  6887.           ZR     X3,S1       IF STATUS=0 ON ENTRY
  6888.           IX3    X7-X3       - (STATUS-LOCF(SWSA))
  6889.           SX6    B5          FWA DWSA
  6890.           PL     X3,S16      IF .GE. 0, RETURN STATUS=LOCF(DWSA)
  6891.           BX6    -X3         WORD COUNT OF VALID DATA
  6892.           SX6    X6-1        ACCOUNT FOR WORD ALREADY PICKED UP
  6893.           SA6    SWSAREM
  6894.           BX2    X1
  6895. S15       BX1    X2          WD1=WD2
  6896. S1        SA3    SWSAREM
  6897.           ZR     X3,S2       IF NO MORE IN SWSA
  6898.           SX6    X3-1
  6899.           SA6    A3
  6900.           SA2    A2+B1       READ NEXT WD2
  6901.           NG     X2,S4       IF COULD BE ALL ONES
  6902.           ZR     X2,S3       IF WD2=0
  6903. S4        MX0    -12
  6904.           BX3    -X0*X1      BYTE 4 OF WD1
  6905.           ZR     X3,S3       IF Z-BYTE TERMINATOR IN WD1
  6906.           SB3    10          DO 10 CHARACTERS
  6907.  
  6908. *         WHETHER WD1 CONTAINS AN EOL OR NOT, CT (B3) IS
  6909. *         NOW THE NUMBER OF LEFTMOST CHARACTERS IN WD1
  6910. *         TO CONVERT.  IF THIS IS THE LAST WORD IN
  6911. *         SWSA (NO WD2), OR IF WD1 CONTAINS AN EOL, THE
  6912. *         EXIT FLAG HAS BEEN SET TO CAUSE AN EXIT
  6913. *         AS SOON AS WD1 IS FINISHED.
  6914.  
  6915. S8        LX1    6
  6916.           MX0    -6
  6917.           BX3    -X0*X1      NEXT WD1 CHAR
  6918.           NE     B2,S9       IF ESCFLAG<>0
  6919.           SX5    X3-76B
  6920.           ZR     X5,S10      IF 76B ESCAPE LEADIN
  6921.           SX5    X3-74B
  6922.           ZR     X5,S11      IF 74B ESCAPE LEADIN
  6923.           SA3    UASCII+X3   CONVERT TO 8/12
  6924.  
  6925. *         X3 IS THE 8/12 ASCII BYTE TO OUTPUT. THE FOLLOWING
  6926. *         CODE (CALLED OUT12 JUST TO IDENTIFY IT AS A LOGICAL
  6927. *         UNIT) PUTS THE BYTE INTO DWSA.
  6928.  
  6929. S13       LX3    X3,B4
  6930.           BX4    X4+X3       PUT INTO WORD UNDER CONSTRUCTION
  6931.           SB4    B4-12
  6932.           PL     B4,S14      IF OUT12 WORD NOT FULL
  6933.           BX6    X4
  6934.           SA6    B5          STORE IN DWSA
  6935.           SB5    B5+B1
  6936.           EQ     B5,B6,S12   IF DWSA NOW FULL
  6937.           MX4    0
  6938.           SB4    48          START OVER WITH NEXT WORD
  6939. S14       SB3    B3-B1
  6940. S7        NE     B3,S8
  6941.           SA3    EXITFLG
  6942.           ZR     X3,S15      IF NOT TIME TO QUIT
  6943.           BX6    X4
  6944.           SA6    B5          FINISH LAST WORD
  6945. S12       SA1    STATADR
  6946.           SA1    X1
  6947.           ZR     X1,SXXXA8   IF ZERO ON ENTRY
  6948.           SX6    B5
  6949. S16       SA1    STATADR
  6950.           SA6    X1
  6951.           EQ     SXXXA8
  6952.  
  6953. *         ESCFLAG CONTAINS THE ADDRESS OF THE 74 OR 76 TRANSLATION
  6954. *         TABLE, SO LOOK UP THE TRANSLATED CHARACTER AND
  6955. *         INDICATE THAT THE ESCAPE SEQUENCE IS DONE BY
  6956. *         SETTING ESCFLAG BACK TO ZERO, UNLESS WE ARE DOING DPC
  6957. *         CONVERSION.
  6958.  
  6959. S9        SA3    B2+X3
  6960.           SB7    UASCII      CHECK FOR DPC CONVERSION
  6961.           EQ     B2,B7,S13   DPC CONVERSION.  DON'T RESET ESCFLAG
  6962.           SB2    B0          ESCFLAG=0
  6963.           EQ     S13
  6964.  
  6965. *         IF A 74B IS FOUND, SET ESCFLAG TO THE 74 TRANSLATION TABLE
  6966. *         FWA. SIMILARLY FOR 76B.
  6967.  
  6968. S10       SB2    SX1276
  6969.           EQ     S14
  6970. S11       SB2    SX1274
  6971.           EQ     S14
  6972. S2        SX6    B1
  6973.           SA6    EXITFLG
  6974.           EQ     S4
  6975.  
  6976. *         WE HAVE FOUND AN EOL. COUNT THE NUMBER OF
  6977. *         LEADING NON-ZERO CHARACTERS IN WD1.
  6978.  
  6979. S3        SX6    B1
  6980.           SA6    EXITFLG
  6981.           BX5    X1          WD1
  6982.           SB7    10          MAX LOOP COUNT
  6983.           SB3    B7          INITIALIZE COUNT
  6984.           MX0    -6
  6985. S6        BX3    -X0*X5      RIGHTMOST WD1 CHAR
  6986.           NZ     X3,S7       IF NON-ZERO CHAR
  6987.           SB3    B3-B1       COUNT A ZERO CHAR (NEGATIVELY)
  6988.           LX5    -6
  6989.           SB7    B7-B1
  6990.           NE     B7,S6
  6991.           EQ     S7
  6992.  
  6993. EXITFLG   BSS    1           NZ IF TO QUIT AFTER DOING THIS WD1
  6994. SWSAREM   BSS    1           WORDS REMAINING TO BE DONE IN SWSA
  6995. STATADR   BSS    1           ADDRESS OF STATUS PARAMETER
  6996.  A8SX12   SPACE  4,10
  6997.           ENTRY  A8SX12
  6998.           ENTRY  A8DPC
  6999. ***       A8SX12 - CONVERT 8/12 TO 6/12.
  7000. *         A8DPC - CONVERT 8/12 TO DISPLAY CODE
  7001. *
  7002. *         CONVERT THE 8/12 ASCII DATA IN SRC TO 6/12 ASCII
  7003. *         OR DISPLAY CODE IN THE SAME BUFFER.
  7004. *
  7005. *         REGISTER ASSIGNMENTS -
  7006. *         X0    - MASK(-7)
  7007. *         A1/X1 - CURRENT SOURCE WORD
  7008. *         X5    - LAST CHARACTER OUTPUT
  7009. *         X6    - CURRENT DESTINATION WORD
  7010. *         B2    - NUMBER OF BYTES LEFT IN X1
  7011. *         B3    - NUMBER OF WORDS REMAINING IN SRC
  7012. *         B5    - OUTPUT WORD BYTE SHIFT COUNT
  7013. *         B6    - DESTINATION ADDRESS
  7014. *         B7    - CONVERSION TABLE ADDRESS
  7015.  
  7016. A8SX12    SUBR               ENTRY/EXIT
  7017.           SB7    ASC612      CONVERT TO 6/12
  7018.           RJ     A8XXXX
  7019.           EQ     A8SX12      RETURN
  7020.  
  7021.  A8DPC    SUBR
  7022.           SB7    DPCTBL      CONVERT TO DISPLAY CODE
  7023.           RJ     A8XXXX
  7024.           EQ     A8DPC       RETURN
  7025.  
  7026.  
  7027.  A8XXXX   PS                 INTERNAL ENTRY/EXIT
  7028.           SB1    1
  7029.           SB6    X1          SRC
  7030.           SA1    A1+B1
  7031.           SA1    X1
  7032.           SB3    X1          N
  7033.           EQ     B3,A8XXXX   IF NOTHING TO DO
  7034.           SA1    B6          A1=SRC
  7035.           SB5    54
  7036.           MX6    0           INITIALIZE DESTINATION WORD
  7037.           MX0    -7
  7038. L2        SB2    5
  7039. L1        LX1    12
  7040.           BX2    -X0*X1
  7041.           ZR     X2,L5
  7042.  L11      SA3    B7+X2       CONVERT CHARACTER
  7043.           SB4    X3-100B
  7044.           PL     B4,L3
  7045. L4        RJ     OUT6
  7046.           SB2    B2-B1
  7047.           NE     B2,L1
  7048. L9        SB3    B3-B1
  7049.           EQ     B3,EXIT
  7050.           SA1    A1+B1
  7051.           EQ     L2
  7052.  
  7053. *         THE TABLE ENTRY INDICATES THE NEED FOR AN
  7054. *         ESCAPE SEQUENCE.
  7055.  
  7056. L3        BX4    X3          SAVE TABLE ENTRY
  7057.           AX3    6
  7058.           SX3    X3          LEADING CHARACTER (74B OR 76B)
  7059.           RJ     OUT6
  7060.           MX3    -6
  7061.           BX3    -X3*X4      SECOND CHARACTER
  7062.           EQ     L4
  7063.  
  7064. *         CHECK FOR A POSSIBLE EOL BYTE.
  7065.  
  7066. L5        MX4    -12
  7067.           BX4    -X4*X1      ALL 12 BITS OF BYTE
  7068.           NZ     X4,L11      IF NOT A 12-BIT ZERO
  7069.           RJ     EOL
  7070.           EQ     L9
  7071.  
  7072. EXIT      RJ     EOL
  7073.           EQ     A8XXXX
  7074.  
  7075. *         PUT AN EOL IN THE OUTPUT.
  7076.  
  7077. EOL       BSS    1
  7078.           NZ     X5,EOL1
  7079.  
  7080. *         THE LAST CHARACTER OUTPUT WAS A COLON. PROTECT IT
  7081. *         BY OUTPUTTING A BLANK AFTER IT.
  7082.  
  7083.           SX3    1R
  7084.           RJ     OUT6
  7085. EOL1      EQ     B5,L6       IF 66-BIT EOL NEEDED
  7086.           SB5    B5-54
  7087.           EQ     B5,L7       IF 60-BIT EOL NEEDED
  7088.  
  7089. *         THE EOL IS OK AS IS IN THE OUTPUT WORD.
  7090.  
  7091.           EQ     L10
  7092. L6        SA6    B6
  7093.           SB6    B6+B1
  7094. L7        MX6    0
  7095. L10       SA6    B6
  7096.           SB6    B6+B1
  7097.           SB5    54
  7098.           EQ     EOL
  7099.  
  7100. *         PUT A 6-BIT CHAR INTO THE OUTPUT WORD
  7101.  
  7102. OUT6      BSS    1
  7103.           BX5    X3
  7104.           LX3    X3,B5
  7105.           BX6    X6+X3
  7106.           SB5    B5-6
  7107.           PL     B5,OUT6
  7108.           SA6    B6
  7109.           SB6    B6+B1
  7110.           SB5    54
  7111.           MX6    0
  7112.           EQ     OUT6
  7113.           END
  7114.       LOGICAL FUNCTION WILDMAT(NAME)
  7115.  
  7116.       CHARACTER NAME*(*)
  7117.       INTEGER SEGM(7)
  7118.  
  7119. *     START OF COMMON BLOCK FOR WILDCARD ROUTINES
  7120.  
  7121.       COMMON /WILD/ WSEGC, WSEGL(1:7), WFFIX, WLFIX, WCOM
  7122.       INTEGER WSEGC, WSEGL
  7123.       LOGICAL WFFIX, WLFIX, WCOM
  7124.       COMMON /WILDC/ WSEG(1:7)
  7125.       CHARACTER WSEG*7
  7126.  
  7127. *     END OF COMMON BLOCK FOR WILDCARD ROUTINES
  7128.  
  7129. *
  7130. *     DETERMINE FILE NAME STRING LENGTH, CHECK FOR ALL BLANK STRING.
  7131. *
  7132.       L = INDEX(NAME, ' ')-1
  7133.       IF(L .EQ. 0) THEN
  7134.          WILDMAT = WCOM
  7135.          RETURN
  7136.       ELSE IF(L .EQ. -1) THEN
  7137.          L = LEN(NAME)
  7138.       ENDIF
  7139.  
  7140.       IPOS = 1
  7141. *
  7142. *     LOOK FOR FIRST MATCH OF SEGMENT 'ISEG' IN 'NAME'.
  7143. *
  7144.       DO 10 ISEG = 1, WSEGC
  7145. 20    CONTINUE
  7146. *
  7147. *     LOOK FOR MATCH IN 'NAME' FOLLOWING THIS POINT.  IF FAILURE, BUT
  7148. *     WE HAVEN'T RUN OUT OF 'NAME' YET, BUMP STARTING POINT AND
  7149. *     TRY AGAIN.
  7150. *
  7151.       SEGM(ISEG) = IPOS
  7152.       DO 30 I = 1, WSEGL(ISEG)
  7153.       IF((WSEG(ISEG)(I:I).EQ. '?') .OR.
  7154.      +   (WSEG(ISEG)(I:I).EQ.NAME(IPOS:IPOS))) THEN
  7155. *        PRINT *, 'OK',ISEG, I, IPOS
  7156.          IPOS = IPOS + 1
  7157.          IF((IPOS.GT.L) .AND. ((ISEG.NE.WSEGC) .OR.
  7158.      +      (I.NE.WSEGL(ISEG)))) THEN
  7159.             WILDMAT = WCOM
  7160.             RETURN
  7161.          ENDIF
  7162.       ELSE
  7163. *        PRINT *, 'NO',ISEG, I, IPOS
  7164.          IPOS = SEGM(ISEG)+1
  7165.          IF(IPOS .GT. L) THEN
  7166.             WILDMAT = WCOM
  7167.             RETURN
  7168.          ENDIF
  7169.          GO TO 20
  7170.       ENDIF
  7171. 30    CONTINUE
  7172. *
  7173. *     AT THIS POINT, SEGMENT 'ISEG' MATCHES.
  7174. *     IF WFFIX, ENSURE FIRST SEGMENT MATCH IS AT START OF NAME.
  7175. *     IF WLFIX, ENSURE LAST SEGMENT IS AT END; IF NOT TRY IT.
  7176. *
  7177.       IF((ISEG.EQ.1) .AND. WFFIX .AND. (SEGM(1).NE.1)) THEN
  7178.          WILDMAT = WCOM
  7179.          RETURN
  7180.       ENDIF
  7181.       IF((ISEG.EQ.WSEGC) .AND. WLFIX .AND. (IPOS.NE.L+1)) THEN
  7182.          IPOS = L-WSEGL(WSEGC)+1
  7183. *        PRINT *, 'LAST SEG RESTART.'
  7184.          GOTO 20
  7185.       ENDIF
  7186. 10    CONTINUE
  7187.       WILDMAT = (.NOT.WCOM)
  7188. *
  7189. *     WE HAVE A MATCH.  RETURN.
  7190. *
  7191. *     PRINT *,WILDMAT,' MATCH ',(SEGM(I),I=1, WSEGC)
  7192.       RETURN
  7193.       END
  7194.       LOGICAL FUNCTION WILDSET(WILDNAM)
  7195.  
  7196.       CHARACTER *(*) WILDNAM, C*1
  7197.       LOGICAL BREAK
  7198.       INTEGER SEGS(1:7), SEGE(1:7)
  7199.  
  7200. *     START OF COMMON BLOCK FOR WILDCARD ROUTINES
  7201.  
  7202.       COMMON /WILD/ WSEGC, WSEGL(1:7), WFFIX, WLFIX, WCOM
  7203.       INTEGER WSEGC, WSEGL
  7204.       LOGICAL WFFIX, WLFIX, WCOM
  7205.       COMMON /WILDC/ WSEG(1:7)
  7206.       CHARACTER WSEG*7
  7207.  
  7208. *     END OF COMMON BLOCK FOR WILDCARD ROUTINES
  7209.  
  7210.  
  7211.       WSEGC = 0
  7212.       BREAK = .TRUE.
  7213.       WFFIX = .FALSE.
  7214.       WLFIX = .FALSE.
  7215. *
  7216. *     DETERMINE WILDCARD STRING LENGTH, CHECK FOR ALL BLANK STRING
  7217. *
  7218.       L = INDEX(WILDNAM, ' ')-1
  7219.       IF(L .EQ. -1) L = LEN(WILDNAM)
  7220.       WCOM = (WILDNAM(L:L) .EQ. '-')
  7221.       IF(WCOM) L = L - 1
  7222.       IF(L .EQ. 0) THEN
  7223.          WILDSET = .FALSE.
  7224.          RETURN
  7225.       ENDIF
  7226. *
  7227. *     EXAMINE WILDCARD STRING.  BREAK INTO SEGMENTS CONSISTING OF
  7228. *     A-Z,0-9,? STRINGS, TERMINATING WITH *.
  7229. *     IF FIRST PIECE OF STRING IS SEGMENT (NO LEADING *), SET WFFIX.
  7230. *     IF LAST PIECE IS SEGMENT, SET WLFIX.
  7231. *
  7232.       DO 10 I=1, L
  7233.       C = WILDNAM(I:I)
  7234.       IF(C .EQ. '*') THEN
  7235.          BREAK = .TRUE.
  7236.       ELSE IF((C.GE.'A'.AND.C.LE.'Z').OR.(C.GE.'0'.AND.C.LE.'9')
  7237.      +        .OR. C.EQ.'?') THEN
  7238.          IF(I .EQ. 1) WFFIX = .TRUE.
  7239.          IF(I .EQ. L) WLFIX = .TRUE.
  7240.          IF(BREAK) THEN
  7241.             BREAK = .FALSE.
  7242.             IF(WSEGC.LT.7) WSEGC = WSEGC+1
  7243.             SEGS(WSEGC) = I
  7244.             SEGE(WSEGC) = I
  7245.          ELSE
  7246.             SEGE(WSEGC) = I
  7247.          ENDIF
  7248.       ELSE
  7249.          WILDSET = .FALSE.
  7250.          RETURN
  7251.       ENDIF
  7252. 10    CONTINUE
  7253.  
  7254. *     PRINT *,WSEGC, WFFIX, WLFIX
  7255. *
  7256. *     KEEP SEGMENTS AND THEIR LENGTHS FOR ROUTINE 'WILDMAT'.
  7257. *
  7258.       DO 20 I=1, WSEGC
  7259.       WSEG(I) = WILDNAM(SEGS(I):SEGE(I))
  7260.       WSEGL(I) = SEGE(I)-SEGS(I)+1
  7261. *     PRINT '(2I5,2X,A,I5)', SEGS(I), SEGE(I), WSEG(I), WSEGL(I)
  7262. 20    CONTINUE
  7263.  
  7264.       WILDSET = .TRUE.
  7265.       RETURN
  7266.       END
  7267.       INTEGER FUNCTION XVFN(LFN)
  7268.       CHARACTER LFN*(*)
  7269.  
  7270. ***   XVFN - VERIFY CORRECT FORMAT FOR FILE NAME.
  7271. *
  7272. *     ON ENTRY, LFN CONTAINS THE FILE NAME LEFT-JUSTIFIED
  7273. *     IN DISPLAY CODE AND BLANK-FILLED.
  7274. *
  7275. *     CALLED ONLY BY SNDFILE AND SERVER.
  7276.  
  7277.  
  7278.       XVFN=0
  7279.  
  7280.  
  7281.       RETURN
  7282.       END
  7283.