home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / hp9845 / hp9845.bas < prev    next >
BASIC Source File  |  2020-01-01  |  70KB  |  2,155 lines
  1. 10   ! **************************************************************** !
  2. 20   ! **************** New Version for HP9845 Derived from *********** !
  3. 30   ! *                                                              * !
  4. 40   ! *  KERMIT DATA TRANSFER PROGRAM FOR THE HP86 MICROCOMPUTER     * !
  5. 50   ! *                                                              * !
  6. 60   ! *  Version 1.00    :        Date:- 14 Mar 86 at 16:30          * !
  7. 70   ! *                                                              * !
  8. 80   ! *  Programmer:- Martin J. Rootes                               * !
  9. 90   ! *  Location  :- Computer Services Department,                  * !
  10. 100  ! *               Sheffield City Polytechnic.                    * !
  11. 110  ! *                                                              * !
  12. 120  ! **************************************************************** !
  13. 130  ! ******** Rob Fletcher , Chris Walker , University of York ****** !
  14. 131  ! *
  15. 132  ! * LAST UPDATED    6 Nov 86 at 18:30
  16. 133  ! *
  17. 134  ! * This program is designed to send both ordinary data files and
  18. 135  ! * special files stored in BDAT format in a manner unique to the
  19. 136  ! * SAM system. It is also designed to send data in a remote manner
  20. 137  ! * by reading a control file to find which files to send. Hence
  21. 138  ! * the program does not require the presence of a user and with
  22. 139  ! * the aid of the 'AUTOSTART' bootstrap facility, the data may be
  23. 140  ! * sent in the middle of the night.
  24. 141  ! * In order to send ordinary data files, alter line 840 to
  25. 142  ! *      Datatype=1
  26. 143  ! * This program is purely designed to send data to a mainframe
  27. 144  ! * computer. Many of the parameters in the 'SET' commands cannot
  28. 145  ! * be changed. For instance, the PARITY cannot be changed and the
  29. 146  ! * host Kermit must be set to PARITY EVEN. For further information
  30. 147  ! * see the Kermit manual for the HP86 Kermit upon which this program
  31. 148  ! * is based.
  32. 150  !  **************************************************************  !
  33. 160   OPTION BASE 0
  34. 170   MASS STORAGE IS ":Q"
  35. 171   CCOM 4428
  36. 180   COM Cr$[1],Lf$[1],INTEGER Bias,Bias2,Bias3,Lb1,Ub1,Lb2,Ub2,A1,A2,A3,Asoff
  37. 190   INTEGER Sig(17519),Sig1(17159),Sigj,Line_no,Span,Inf,Sig0,Medium(80),Hpfile(80)
  38. 200   DIM Info$(50),Title$[256],Line1$[180],Line2$[200],Line3$[200],Left$[256]
  39. 210   DIM Ins$(80)[18]
  40. 220 DIM Ibuff$[264],Obuff$[264] ! Define input & output buffers
  41. 230 DIM K$[1],Kk$[1],I$[256],Line$[80] ! Define string variables
  42. 240 DIM Esc$[1],Bel$[1] ! Define control characters
  43. 250 DIM El$[1],Bs$[1],Del$[1],Null$[1] !  ''     ''       ''
  44. 260 DIM Sp$[1] !  Define space
  45. 270   DIM Resp$[1]
  46. 280 INTEGER S1,S2,S3,S4,K,R,C,I,F ! Define integer variables
  47. 290   PRINTER IS 16
  48. 300 Cr$[1]=CHR$(13)
  49. 310 Lf$=CHR$(10)  !  <CR> & <LF>
  50. 320 Esc$[1]=CHR$(27)
  51. 330 Bel$=CHR$(7)  ! Escape & bell
  52. 340 El$[1]=CHR$(154)
  53. 350 Bs$=CHR$(155)  !  Endline & Backspace keys
  54. 360 Del$[1]=CHR$(127)
  55. 370 Null$=CHR$(0)  ! Delete & Null
  56. 380   Brk$=CHR$(2)
  57. 390   Ebrk$=CHR$(28)
  58. 400 Sp$=" " !     Space
  59. 410 DIM Rp$[96],Op$[96],Id$[91],Od$[91] ! Packets
  60. 420 DIM S$[256],Db$[256],Sf$[17],Df$[40],T$[1],Rt$[1],Cc$[1] !
  61. 430 DIM Si$[1],Sh$[1],Sd$[1],Se$[1],Sb$[1],Tm$[1],Ak$[1],Nk$[1] ! Packet types
  62. 440 DIM Rqctl$[1],Sqctl$[1],Rpadc$[1],Spadc$[1] !  Prefix & pad
  63. 450 DIM Mk$[1],Seol$[1],Reol$[1],Crlf$[4] !  Mark & EOLs
  64. 460 INTEGER N,S,T,Ee,Ff,Ii,Jj,Ll,Mm,Rr,Tt,Np ! Temp vars
  65. 470   INTEGER Nn,Rn,Db,Ttmo,Nk,Bp,Rrr,Rc,Sr,Ssc !  Parameters
  66. 480 INTEGER Rmaxl,Smaxl,Maxl,Minl,Rto,Sto,Rnpad,Snpad,Reol,Seol,Tmo,Stm,Rlim
  67. 490 Si$="S"
  68. 500 Sh$="F"
  69. 510 Sd$="D"
  70. 520 Se$="Z"
  71. 530 Sb$="B" !  Send packet types
  72. 540 Ak$="Y"
  73. 550 Nk$="N"
  74. 560 Tm$="T"
  75. 570 Er$="E" ! Other packet types
  76. 580 Mk$=CHR$(1)
  77. 590 Crlf$="#M#J" ! Mark ^A, <CR><LF>
  78. 600 Seol$=Reol$=Cr$
  79. 610 Rpadc$=Null$
  80. 620 Sqctl$="#" !  EOL's, pad char & prefix
  81. 630 Rmaxl=94
  82. 640 Rto=Sto=20
  83. 650 Rnpad=0
  84. 660 Seol=13 !  Max len, Timeouts, pad & eol
  85. 670 Rlim=10
  86. 680 Stm=10000
  87. 690 Rrr=17
  88. 700 Sr=15
  89. 710 Rc=Ssc=10 ! Retries, send timeout
  90. 720 Db=1 !                 Debug (ON FOR TESTING)
  91. 730 DIM F$[80],Cl$[61],Cp$[24]
  92. 740 Cl$="CONNECT, SEND, RECEIVE, SET, SHOW, EXIT, QUIT, CAT"
  93. 750 Kp$="KERMIT-HP9845"
  94. 760 Cp$=Kp$ !  Kermit prompt, Command prompt
  95. 770 DIM Vc$[63],Dt$[1],Cn$[1],Ul$[1],Ftyp$[8] ! Dimension variables
  96. 780 Vc$=".1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ" ! Legal characters
  97. 790 Dt$="."
  98. 800 Cn$=":"
  99. 810 Ul$="_"
  100. 820 Q$=CHR$(34)  !  Dot, colon, underline & quote
  101. 830 Ftyp$="ENC" !        Default file type
  102. 831   ! Data type 1 is for the standard DATA file
  103. 832   ! Data type 2 is for the SAM BDAT files.
  104. 840   Data_type=2
  105. 850   Line_no=1
  106. 860   Sigj=1
  107. 870   Span=1
  108. 880   Bias=33
  109. 890   Bias2=Bias+27
  110. 900   Bias3=Bias+54
  111. 910   Lb1=-13
  112. 920   Ub1=12
  113. 930   Lb2=-1052
  114. 940   Ub2=971
  115. 950   A1=27
  116. 960   A2=81
  117. 970   A3=6561
  118. 980   Asoff=13
  119. 990 EXIT GRAPHICS
  120. 1000 ! PAGESIZE 24
  121. 1010 PRINT PAGE
  122. 1020 Rr=0! Set no of lines (24)
  123. 1030 DIM Em$(24)[24]!
  124. 1040 Em$(0)="Transfer successful"
  125. 1050 Em$(1)="Timeout receiving"
  126. 1060 Em$(2)="NAK received"
  127. 1070 Em$(3)="Checksum error"
  128. 1080 Em$(4)="Incorrect packet"
  129. 1090 Em$(5)="Timeout sending"
  130. 1100 Em$(6)="Cannot rename file"
  131. 1110 Em$(7)="Disc write protected"
  132. 1120 Em$(8)="**File closed*"
  133. 1130 Em$(9)="File does not exist"
  134. 1140 Em$(10)="Incorrect file type"
  135. 1150 Em$(11)="*Random overflow*"
  136. 1160 Em$(12)="Read error"
  137. 1170 Em$(13)="End of file"
  138. 1180 Em$(14)="Record does not exist"
  139. 1190 Em$(15)="No M.S. device"
  140. 1200 Em$(16)="Directory full"
  141. 1210 Em$(17)="Volume not found"
  142. 1220 Em$(18)="MSUS not found"
  143. 1230 Em$(19)="Read verify error"
  144. 1240 Em$(20)="Disc full"
  145. 1250 Em$(21)="Medium damaged"
  146. 1260 Em$(22)="Disc drive fault"
  147. 1270 Em$(23)="Data type error"
  148. 1280 Em$(24)="Transfer aborted"
  149. 1290 Fse$=CHR$(60)
  150. 1300 FOR Ii=66 TO 72
  151. 1310 Fse$=Fse$&CHR$(Ii)
  152. 1320 NEXT Ii
  153. 1330 Fse$=Fse$&CHR$(120)
  154. 1340 FOR Ii=124 TO 130
  155. 1350 Fse$=Fse$&CHR$(Ii)
  156. 1360 NEXT Ii
  157. 1370 DIM A$(9)[18],St$(1)[9],Sst$(1)[8]
  158. 1380 A$(0)="initialise        "
  159. 1390 A$(1)="file header      "
  160. 1400 A$(2)="data              "
  161. 1410 A$(3)="end of file      "
  162. 1420 A$(4)="break             "
  163. 1430 A$(5)="error            "
  164. 1440 A$(6)="ACK               "
  165. 1450 A$(7)="NAK              "
  166. 1460 A$(8)="file header/break "
  167. 1470 A$(9)="data/EOF         "
  168. 1480 St$(0)="Sending"
  169. 1490 Sst$(0)="sent"
  170. 1500 St$(1)="Receiving"
  171. 1510 Sst$(1)="received"
  172. 1520 DIM Re$[4],Pf$[18]! End of record sequence, previous file name
  173. 1530 INTEGER Re,Rl,Nr! No of chars in Re$, Record length, No of records
  174. 1540 Re$=Cr$&Lf$
  175. 1550 Re=LEN(Re$)
  176. 1560 Rl=256
  177. 1570 Nr=40
  178. 1580 Fs=Rl*Nr/1024
  179. 1590 Pf$=" "
  180. 1600 DIM Sl$[164],Oo$[7],Dx$[10],Fc$[23],Pt$[28],Br$[8],Hs$[29]
  181. 1610 Sl$="TIMEOUT, RETRIES, SEND-CONVERT, DEBUG, PREFIX, END-OF-LINE, "
  182. 1620 Sl$=Sl$&"RECORD-END, FILE-SIZE, RECORD-LENGTH, NO-OF-RECORDS, "
  183. 1630 Sl$=Sl$&"DUPLEX, LOCAL-ECHO, FLOW-CONTROL, HANDSHAKE, PARITY"
  184. 1640 Oo$="OFF, ON"
  185. 1650 Dx$="FULL, HALF"
  186. 1660  Fc$="NONE, XON/XOFF, DTR/RTS"
  187. 1670 Pt$="NONE, ODD, EVEN, MARK, SPACE"
  188. 1680  Br$="110, 300"
  189. 1690 Hs$="NONE, BELL, LF, CR, XON, XOFF"
  190. 1700 DIM Ss$[47],Rs$[32]
  191. 1710 Ss$="SEND "&Q$&"Source filename"&Q$&" <"&Q$&"Destination filespec"&Q$&">"
  192. 1720 Rs$="RECEIVE <"&Q$&"Destination filespec"&Q$&">"
  193. 1730 DIM Io$[14],Ic$[14],Iv$[13]
  194. 1740 Io$="Illegal option"
  195. 1750 Ic$="Illegal string"
  196. 1760 Iv$="Illegal value"
  197. 1770 INTEGER Br,Dx,Le,Fc,Hs,Pt,Sc,Ps,Pp,Nf,Ft
  198. 1780 Br=Dx=Le=1
  199. 1790 Pt=3
  200. 1800 Fc=Sc=Ps=0
  201. 1810 Hs=4
  202. 1820   GOSUB Rs_set
  203. 1830  CALL Get_info(Fnumber,Auto,Ins$(*),Medium(*),Hpfile(*))
  204. 1840    IF Auto THEN
  205. 1850    GOSUB Connect
  206. 1860    GOSUB Login
  207. 1870    GOSUB R_kermit
  208. 1880    FOR Af=1 TO Fnumber
  209. 1900    IF Ins$(Af)[1,1]="R" THEN
  210. 1901    CWRITE 2;"RECEIVE",ENDLINE
  211. 1902    GOSUB Exit1
  212. 1910    S$=CHR$(34)&"G"&VAL$(Hpfile(Af))&CHR$(34)
  213. 1920    GOSUB Send_file
  214. 1930    GOTO 1990
  215. 1940    END IF
  216. 1950    IF Ins$(Af)[1,1]="S" THEN
  217. 1951    CWRITE 2;Ins$(Af),ENDLINE
  218. 1952    GOSUB Exit1
  219. 1960    GOSUB Rec_file
  220. 1970    GOTO 1990
  221. 1980    END IF
  222. 1990    NEXT Af
  223. 1991    GOSUB End_job
  224. 2000    END IF
  225. 2010 ! ******************************************************************** !
  226. 2020 ! *                                                                  * !
  227. 2030 ! *                  COMMAND PROCESSOR SECTION                       * !
  228. 2040 ! *                                                                  * !
  229. 2050 ! ******************************************************************** !
  230. 2060 ! #
  231. 2070 ! # This section passes a parameter list to the required command in S$
  232. 2080 !
  233. 2090 ! COMMAND PROCESSOR
  234. 2100 ! -----------------
  235. 2110 Com_proc:GOSUB Dkeys  ! Set keys to jump to dummy routine
  236. 2120 CALL Bwrite(20,0)
  237. 2130 PRINT Cp$&" > Enter command ";! Display command prompt
  238. 2140 RESUME INTERACTIVE! Resort to normal keyboard operation
  239. 2150 LINPUT S$
  240. 2160 Cp$=Kp$! Input string, reset command prompt
  241. 2170 SUSPEND INTERACTIVE ! Block out keyboard again
  242. 2180 CALL Awrite(19,0,RPT$(" ",80))   ! Blank any message from previous command
  243. 2190 CALL Awrite(22,0,RPT$(" ",160))   !  ''   ''    ''     ''     ''      ''
  244. 2200 GOSUB Split !  Split at first space
  245. 2210 C=FNInlist(F$,Cl$,Sp$)!   Is command in command list
  246. 2220 IF C=0 THEN CALL Awrite(22,0,"Invalid command - "&F$) ! No - display
  247. 2230 IF C<1 THEN 2120!  ? - re-enter
  248. 2240 ON C GOSUB Connect,Send_file,Rec_file,Set,Show_pars,Exit,Exit,Dir
  249. 2250 GOTO Com_proc
  250. 2260 !
  251. 2270 ! ROUTINE TO SPLIT STRING AT FIRST SPACE OR QUOTE
  252. 2280 ! -----------------------------------------------
  253. 2290 Split:S$=TRIM$(S$)  !  Trim leading/trailing spaces
  254. 2300 Pp=POS(S$,Q$)
  255. 2310 P=POS(S$,Sp$) ! Find position of qoute & space
  256. 2320 IF Pp*P=0 THEN
  257. 2330 IF Pp>P THEN P=Pp
  258. 2340 ELSE
  259. 2350 IF Pp<P THEN P=Pp
  260. 2360 END IF
  261. 2370 IF P=0 THEN
  262. 2380 F$=S$
  263. 2390 S$=""
  264. 2400 ELSE
  265. 2410 F$=S$[1,P-1]
  266. 2420 S$=S$[P,LEN(S$)]
  267. 2430 END IF
  268. 2440 RETURN !  RETURN F$=First 'word' S$=rest
  269. 2450 !
  270. 2460 ! EXIT ROUTINE
  271. 2470 ! ------------
  272. 2480 Exit:PRINT PAGE
  273. 2490 RESUME INTERACTIVE
  274. 2500 CDISCONNECT 2;HOLD          ! ABORTIO 10
  275. 2510 PRINT "Kermit finished"
  276. 2520 END
  277. 2530 !
  278. 2540 ! CATALOGUE DISK
  279. 2550 ! --------------
  280. 2560 Dir:ON ERROR GOSUB Fserr
  281. 2570 Ff=0!  Set error trap
  282. 2580 S$=TRIM$(S$)
  283. 2590 ! IF S$#"" THEN CAT S$ ELSE CAT ! Catalogue disk
  284. 2600 IF Ff<>0 THEN
  285. 2610 CALL Awrite(19,0,Em$(Ff))
  286. 2620 RETURN ! If error display message
  287. 2630  END IF
  288. 2640 FOR I=1 TO 4
  289. 2650 PRINT
  290. 2660 NEXT I
  291. 2670 RETURN ! Move screen up 4 lines
  292. 3050  !
  293. 3060 Login:  CWRITE 2;ENDLINE
  294. 3070  CWRITE 2;"CALL VAXA",ENDLINE
  295. 3071  CWRITE 2;"PHYS2",ENDLINE
  296. 3080  Pass$="BAGDIN"
  297. 3090  CWRITE 2;Pass$,ENDLINE
  298. 3100  RETURN
  299. 3110  !
  300. 3120 R_kermit:  CWRITE 2;"KERMIT",ENDLINE
  301. 3130  CWRITE 2;"SET PARITY EVEN",ENDLINE
  302. 3131  RETURN
  303. 3132 End_job:  CWRITE 2;"Q",ENDLINE
  304. 3133  CWRITE 2;"LOGOUT",ENDLINE
  305. 3134  GOTO Exit
  306. 3159 ! ****************************************************************** !
  307. 3160 ! *                                                                * !
  308. 3170 ! *                     TERMINAL EMULATION                         * !
  309. 3180 ! *                                                                * !
  310. 3190 ! ****************************************************************** !
  311. 3200 Connect: F=Ff=0 !  Reset escape flag & cr flag
  312. 3210 C=0
  313. 3220 CALL Bwrite(0,0)
  314. 3230 PRINT PAGE !   Clear screen
  315. 3240 PRINT "HP98 Kermit - Terminal emulation mode"
  316. 3250 PRINT
  317. 3260 PRINT "Function key   Escape character   Action"
  318. 3270 PRINT "--------------------------------------------------"
  319. 3280 PRINT "   k1                 C           RETURN to KERMIT"
  320. 3290 PRINT "   k7                 B           Transmit break"
  321. 3300 PRINT "   k14                            Enable transmit"
  322. 3310 PRINT "   REMEMBER TO 'SET PARITY EVEN' ON HOST COMPUTER"
  323. 3320 CALL Bwrite(20,0)  ! Move cursor to first position
  324. 3330 Del=5 !    Keyboard delay = 05 milliseconds
  325. 3340  ON KBD 3 GOSUB Outkey
  326. 3350  CCONTROL 2;XON
  327. 3360  ON INT #3,2 GOSUB Receive
  328. 3370  ON INT #2,1 GOSUB Transmit
  329. 3380 Kk$=" "
  330. 3390  IF Auto THEN RETURN
  331. 3400 !
  332. 3410 !   START OF LOOP
  333. 3420 !   -------------
  334. 3430  Eactive=1
  335. 3440 Spin:  IF Eactive THEN Spin
  336. 3450  OFF INT #3
  337. 3460  OFF INT #2
  338. 3470  RETURN
  339. 3480 Transmit:  IF NOT CSTAT(2,2) THEN RETURN
  340. 3490  CREAD 2;A$
  341. 3500  PRINT A$;
  342. 3510  RETURN
  343. 3520 Receive:  IF NOT CSTAT(2,1) THEN RETURN
  344. 3530  CREAD 2;A$
  345. 3540  PRINT A$;
  346. 3550  IF CSTAT(2,3) THEN PRINT
  347. 3560  GOTO Receive
  348. 3570 Outkey: Line$=KBD$
  349. 3580  IF POS(Line$,Brk$) THEN Break
  350. 3590  IF NOT Eactive THEN RETURN
  351. 3600  IF POS(Line$,Ebrk$) THEN 3690
  352. 3610  IF NUM(Line$)<255 THEN 3670
  353. 3620  IF NUM(Line$[2;1])=1 THEN Exit1
  354. 3630  IF NUM(Line$[2;1])=7 THEN GOSUB Break
  355. 3640  IF NUM(Line$[2;1])=14 THEN GOSUB Tx_en
  356. 3650  CWRITE 2;ENDLINE
  357. 3660  RETURN
  358. 3670  CWRITE 2;Line$
  359. 3680  RETURN
  360. 3690  Eactive=0
  361. 3700  RETURN
  362. 3710 Force_exit:  CCONTROL 2;SUSPEND
  363. 3720  PRINT "ABORT ON FATAL ERROR"
  364. 3730  RETURN
  365. 3740 !
  366. 3750 !   EXIT ROUTINE
  367. 3760 !   ------------
  368. 3770 Exit1: ! END ALL INPUT/OUTPUT
  369. 3780 RESUME INTERACTIVE
  370. 3790  OFF INT #2
  371. 3800  OFF INT #3
  372. 3810 PRINT PAGE ! Reset
  373. 3820  Eactive=0
  374. 3830 RETURN !          RETURN
  375. 3840 !
  376. 3850 !   TRANSMIT A BREAK
  377. 3860 !   --------------------
  378. 3870 Break:! REQUEST 2;8
  379. 3880 CCONTROL 2;SUSPEND
  380. 3890  PRINT LIN(1),"****  BREAK ****"
  381. 3900 RETURN ! Transmit break signal
  382. 3910 !
  383. 3920 !   RE-ENABLE TRANSMITER
  384. 3930 !   --------------------
  385. 3940 Tx_en: CCONTROL 2;XON  ! RESUME 10     @@@@
  386. 3950  ON INT #3,2 GOSUB Receive
  387. 3960  ON INT #2,1 GOSUB Transmit
  388. 3970 RETURN !   Re-enable transmiter
  389. 3980 ! ***************************************************************** !
  390. 3990 ! *                                                               * !
  391. 4000 ! *       SEND FILE - EXTRACT FILE NAME SECTION                   * !
  392. 4010 ! *                                                               * !
  393. 4020 ! ***************************************************************** !
  394. 4030 ! # This section extracts the file names from the parameter list following
  395. 4040 ! # the SEND command .
  396. 4050 ! # S$ - contains the parameter list
  397. 4060 ! #
  398. 4070 !
  399. 4080 !   EXTRACT FILE NAMES FROM PARAMETER LIST
  400. 4090 !   --------------------------------------
  401. 4100 Send_file: S$=TRIM$(S$)
  402. 4110 CCONTROL 2;READALL ON
  403. 4120  Line_no=1
  404. 4130  Sigj=1
  405. 4140  Span=2
  406. 4150  Sig0=0
  407. 4160 Df$="" !  Strip excess blanks from parameters
  408. 4170 IF S$="?" THEN
  409. 4180 CALL Awrite(22,0,Ss$)
  410. 4190 RETURN ! Display send syntax
  411. 4200  END IF
  412. 4210 Pp=FNFsplit(S$,Q$,Ll)
  413. 4220 IF Pp=0 THEN Errfn ! Check for "filename"
  414. 4230 Sf$=TRIM$(S$[2,Pp])  ! Get source filename
  415. 4240 IF Ll<Pp+2 THEN Volrem !   If no dest filename convert source
  416. 4250 S$=TRIM$(S$[Pp+2,Ll])  !   Get destination filename
  417. 4260 Pp=FNFsplit(S$,Q$,Ll)
  418. 4270 IF Pp=0 THEN Errfn ! Check for "filename"
  419. 4280 S$=TRIM$(S$[2,Pp])
  420. 4290 GOTO Chckfn  !  Get destination filename
  421. 4300 !
  422. 4310 !   REMOVE VOLUME OR DRIVE No FROM FILE NAME
  423. 4320 !   ----------------------------------------
  424. 4330 Volrem: S$=Sf$ !      Get file name
  425. 4340 Pp=POS(S$,Dt$)
  426. 4350 IF Pp=0 THEN Pp=POS(S$,Cn$)  ! "." - volume ":" - drive
  427. 4360 IF Pp>0 THEN S$=S$[1,Pp-1] !   Extract file name
  428. 4370 !
  429. 4380 ! CHECK FILE NAME AND CONVERT TO A 'LEGAL' NAME
  430. 4390 ! ---------------------------------------------
  431. 4400 Chckfn: Ll=LEN(S$)
  432. 4410 Ff=0
  433. 4420 Jj=0 ! Get len,clear flag,reset char count
  434. 4430 S$=UPC$(S$)  !  Convert to upper case
  435. 4440 IF POS(S$,Dt$) THEN 4500  !  If name contains "." skip
  436. 4450 Pp=POS(S$,Sp$)
  437. 4460 IF Pp>0 THEN 4490 !  If name contains space convert to "."
  438. 4470 Pp=POS(S$,Ul$)
  439. 4480 IF Pp=0 THEN 4500 !  If name does not contain "_" skip
  440. 4490 S$[Pp,Pp]=Dt$ !   Convert character to "."
  441. 4500 FOR Ii=1 TO Ll
  442. 4510 Pp=POS(Vc$,S$[Ii,Ii])  ! Check char with legal list
  443. 4520 IF (Pp=0) OR (Pp=1) AND ((Ff=1) OR (Jj=0) OR (Jj=Ll-1)) THEN 4560! skip if illegal
  444. 4530 IF Pp=1 THEN Ff=1 !   Set flag to ensure only one "."
  445. 4540 Jj=Jj+1
  446. 4550 Df$[Jj,Jj]=S$[Ii,Ii] !   Transfer legal character to file name
  447. 4560 NEXT Ii
  448. 4570 IF Jj=0 THEN
  449. 4580 Df$=Sf$
  450. 4590 GOTO 4880 !  If file name illegal send source name
  451. 4600  END IF
  452. 4610 Ll=LEN(Df$)
  453. 4620 Pp=POS(Df$,Dt$)  !  Find length of name and "." position
  454. 4630 IF Pp=0 THEN
  455. 4640 Df$=Df$&"."
  456. 4650 Pp=Ll !  If no "." add one to end of Df$
  457. 4660  END IF
  458. 4670 IF Pp=Ll THEN Df$=Df$&Ftyp$ !  If "." at end of Df$ add default type
  459. 4680 ! ******************************************************************** !
  460. 4690 ! *                                                                  * !
  461. 4700 ! *                SEND COMMAND MAIN SECTION                         * !
  462. 4710 ! *                                                                  * !
  463. 4720 ! ******************************************************************** !
  464. 4730 ! # This section sends the file from the HP98 to the remote kermit
  465. 4740 ! # The following variables are used from previous sections
  466. 4750 ! # Sf$ - The source file name
  467. 4760 ! # Df$ - The destination file name
  468. 4770 ! # Also the following parameters changed by SET (* or Y(0))
  469. 4780 ! # Receiving  Sending    Meaning
  470. 4790 ! # Rmaxl      Smaxl  *   Maximum packet length
  471. 4800 ! # Rto     *  Sto        Timeout values
  472. 4810 ! # Rnpad      Snpad  *   Number of padding characters
  473. 4820 ! # Rpadc$     Spadc$ *   Pad character
  474. 4830 ! # Reol       Seol   *   End of line character (end of packet)
  475. 4840 ! # Rqctl$  *  Sqctl$     Prefix character for control characters
  476. 4850 !
  477. 4860 ! OPEN SOURCE FILE
  478. 4870 ! ----------------
  479. 4880 Nn=Pc=Sst=Kk=Snpad=0
  480. 4890 Rt$=""
  481. 4900 Sr=15
  482. 4910 Rrr=17 !  Initialise
  483. 4920 GOSUB Open_read
  484. 4930 IF Ff<>0 THEN Srexit!  Open file
  485. 4940 GOSUB Dsend
  486. 4950 ON KEY #1 GOSUB Abort  ! Display & set abort key
  487. 4960 !
  488. 4970 !  SEND SEND_INIT PACKET
  489. 4980 !  ---------------------
  490. 4990 Send_init: Nn=0
  491. 5000 T$=Si$
  492. 5010 T=0
  493. 5020 Ibuff$="" ! seq no, set type, clear buff
  494. 5030 GOSUB Init_pack
  495. 5040 Od$=In$ ! Set up INIT packet data
  496. 5050 GOSUB Send_pack
  497. 5060 IF Ff<>0 THEN Srexit! Send SEND-INIT
  498. 5070 !
  499. 5080 !   DECODE ACK PACKET TO GET SEND PARAMETERS
  500. 5090 !   ----------------------------------------
  501. 5100 GOSUB Dcd_init  !   Decode INIT data
  502. 5110 !
  503. 5120 !  SEND FILE HEADER
  504. 5130 !  ________________
  505. 5140 Send_head: T$=Sh$
  506. 5150 T=1
  507. 5160 Od$=Df$ ! Set packet type & data = file name
  508. 5170 GOSUB Send_pack
  509. 5180 IF Ff<>0 THEN Srexit! Send packet, exit if error
  510. 5190 !
  511. 5200 ! SEND DATA FROM FILE
  512. 5210 ! -------------------
  513. 5220 T$=Sd$
  514. 5230 T=2
  515. 5240 Db$=""
  516. 5250 Ee=0
  517. 5260 Maxl=Smaxl-3 ! Set type and clear data buf
  518. 5270 Minl=INT(Maxl/2)
  519. 5280 IF Minl<1 THEN Minl=1 ! Set minimum packet length
  520. 5290 GOSUB Get_data
  521. 5300 IF Ff<>0 THEN RETURN ! Get data
  522. 5310 IF Od$="" THEN Send_eof !   If no data send end of file
  523. 5320 GOSUB Send_pack
  524. 5330 IF Ff<>0 THEN Srexit!  Send packet
  525. 5340 IF LEN(Id$)=0 THEN 5290  !  No term - get more data
  526. 5350 IF (Id$[1,1]<>"Z") AND (Id$[1,1]<>"X") THEN 5290! Get more data (unless Stop)
  527. 5360 !
  528. 5370 !  SEND END OF FILE & BREAK PACKETS
  529. 5380 !  --------------------------------
  530. 5390 Send_eof: T$=Se$
  531. 5400 T=3 ! Set up type = send end of file
  532. 5410 GOSUB Send_pack
  533. 5420 IF Ff<>0 THEN Srexit! Send packet
  534. 5430 T$=Sb$
  535. 5440 T=4
  536. 5450 GOSUB Send_pack  ! Set up type = break - send packet
  537. 5460 GOTO Srexit  !   Jump to exit routine
  538. 5470 !
  539. 5480 ! REPORT FILENAME ERROR
  540. 5490 ! ---------------------
  541. 5500 Errfn: Cp$="Filename error"
  542. 5510 RETURN !  Change command prompt & RETURN
  543. 5520 ! ****************************************************************** !
  544. 5530 ! *                                                                * !
  545. 5540 ! *                    RECEIVE COMMAND                             * !
  546. 5550 ! *                                                                * !
  547. 5560 ! ****************************************************************** !
  548. 5570 !
  549. 5580 !  EXTRACT FILENAME (IF SPECIFIED)
  550. 5590 !  -------------------------------
  551. 5600 Rec_file: S$=TRIM$(S$)  !  Strip leading & trailing blanks from params
  552. 5610  CCONTROL 2;READALL ON
  553. 5620  Line_no=1
  554. 5630  Sigj=0
  555. 5640  Span=2
  556. 5650  Sig0=0
  557. 5660 IF S$="?" THEN
  558. 5670 CALL Awrite(22,0,Rs$)
  559. 5680 RETURN ! Display receive syntax
  560. 5690 END IF
  561. 5700 Sr=17
  562. 5710 Rrr=15
  563. 5720 Sst=1
  564. 5730 GOSUB Dsend  !   Initialise display
  565. 5740 Pp=FNFsplit(S$,Q$,Ll)
  566. 5750 IF Pp=0 THEN
  567. 5760 Ft=1
  568. 5770 GOTO 5920 ! Check if filename present
  569. 5780  END IF
  570. 5790 Df$=TRIM$(S$[2,Pp])
  571. 5800 Ft=0 !   Get destination filename
  572. 5810 Pp=POS(Df$,Dt$)
  573. 5820 IF Pp=0 THEN Pp=POS(Df$,Cn$)  ! Volume (.) or MSUS (:)
  574. 5830 IF Pp=0 THEN 5870 !      If none skip
  575. 5840 Vn$=Df$[Pp]
  576. 5850 IF (Pp=1) OR (LEN(Vn$)>6) THEN Errfn! Get volume name & check
  577. 5860 Df$=Df$[1,Pp-1] !        Get file name
  578. 5870 IF LEN(Df$)>10 THEN Errfn  !   Check filename
  579. 5880 CALL Awrite(4,2,St$(1)&" as '"&Df$&"'")   ! Display name
  580. 5890 !
  581. 5900 ! RECEIVE SEND_INIT PACKET
  582. 5910 ! ------------------------
  583. 5920 Rec_init: Nn=Nf=Pc=Kk=0
  584. 5930 Ibuff$=""
  585. 5940 ON KEY #1 GOSUB Abort
  586. 5950 GOSUB Init_pack
  587. 5960 A$=Si$
  588. 5970 T=0 !  Set INIT packet, Allowable type "S"
  589. 5980 GOSUB Get_pack
  590. 5990 IF Ff<>0 THEN Srexit! Get SEND-INIT
  591. 6000 GOSUB Dcd_init  ! Decode SEND-INIT packet
  592. 6010 !
  593. 6020 !  RECEIVE FILE HEADER OR BREAK
  594. 6030 !  ----------------------------
  595. 6040 Rec_head: A$="FBSZ"
  596. 6050 Db$="" !  Valid types F/B (S/Z prev), Clear buffer
  597. 6060 T=8
  598. 6070 GOSUB Get_pack  ! Get File header or Break packet
  599. 6080 IF (Rt$=Sb$) OR (Ff<>0) THEN Srexit! If break received or error exit
  600. 6090 !
  601. 6100 ! EXTRACT FILE NAME, CONVERT & OPEN FILE
  602. 6110 ! --------------------------------------
  603. 6120 Sf$=Id$
  604. 6130 Kk=0 !        Get Fn, reset byte count
  605. 6140  IF Ft=0 THEN
  606. 6150 GOTO 6390
  607. 6160 ELSE
  608. 6170 Df$=Sf$
  609. 6180 Ll=LEN(Df$)
  610. 6190 Pp=POS(Df$,Dt$)  ! Get len, pos of '.'
  611. 6200 IF Ll=0 THEN
  612. 6210 Df$=Dfn$&Dft$
  613. 6220 GOTO 6170 !  Default Fn & Ft
  614. 6230  END IF
  615. 6240 IF Pp=0 THEN 6390 !     No '.' - no seperation
  616. 6250 IF Pp=Ll THEN
  617. 6260 Df$=Df$&Dft$
  618. 6270 GOTO 6170 ! '.' at end add default Ft
  619. 6280  END IF
  620. 6290 IF Pp=1 THEN
  621. 6300 Df$=Dfn$&Df$
  622. 6310 GOTO 6170 ! '.' at start add default Fn
  623. 6320  END IF
  624. 6330 F$=Df$[1,Pp-1]
  625. 6340 IF LEN(F$)>6 THEN F$=F$[1,6]  ! Fn - 6 chars
  626. 6350 S$=Df$[Pp+1,Ll]
  627. 6360 IF LEN(S$)>3 THEN S$=S$[1,3]  ! Ft - 3 chars
  628. 6370 Df$=F$                        !&Sp$&S$
  629. 6380 Ft=LEN(F$)+1  !  Fn Ft
  630. 6390 GOSUB Open_write
  631. 6400 IF Ff<>0 THEN Srexit!  Open file
  632. 6410 CALL Awrite(4,2,St$(1)&" '"&Sf$&"' as '"&Df$&"'")   ! Display file names
  633. 6420 !
  634. 6430 !  RECEIVE DATA OR END OF FILE
  635. 6440 !  ---------------------------
  636. 6450 Rec_data: A$="DZF"
  637. 6460 T=9 !   Valid types D/Z (F prev)
  638. 6470 GOSUB Get_pack
  639. 6480 IF Ff<>0 THEN Srexit!   Get packet
  640. 6490 IF Rt$=Se$ THEN
  641. 6500 GOSUB Close_write
  642. 6510 GOTO Rec_head  ! If EOF close file
  643. 6520  END IF
  644. 6530 GOSUB Put_data
  645. 6540 IF Ff<>0 THEN Srexit!   Store data in file
  646. 6550 GOTO Rec_data  !             Get next data packet
  647. 6560 ! ***************************************************************** !
  648. 6570 ! *                                                               * !
  649. 6580 ! *                    SET/SHOW COMMANDS                          * !
  650. 6590 ! *                                                               * !
  651. 6600 ! ***************************************************************** !
  652. 6610 Show_pars: IF S$="" THEN Sa ! If no parameters after show - show all
  653. 6620 Set: GOSUB Split
  654. 6630 S$=TRIM$(S$)  ! Split parameter string
  655. 6640 Pp=FNInlist(F$,Sl$,Sp$) ! Find if option is in list
  656. 6650 IF Pp<1 THEN
  657. 6660 Df$=F$
  658. 6670 I$=Io$
  659. 6680 GOTO 6840 ! Illegal option
  660. 6690  END IF
  661. 6700 I$=FNXlist$(Sl$,Pp)! Get real option (ie not abbrev.)
  662. 6710 IF C=5 THEN 6830 ! If show just show
  663. 6720 Df$=S$
  664. 6730 O=Pp ! Save option setting
  665. 6740 ! Set
  666. 6750 ON Pp GOSUB S0,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,S12,S13,S14
  667. 6760 IF Pp<1 THEN
  668. 6770 GOTO 6840
  669. 6780 ELSE
  670. 6790 Pp=0
  671. 6800 S$=Df$ ! If error or ? skip else get option
  672. 6810 END IF
  673. 6820 ! Show
  674. 6830 ON Pp+1 GOSUB Dummy,Ss0,Ss1,Ss2,Ss3,Ss4,Ss5,Ss6,Ss7,Ss8,Ss9,Ss10,Ss11,Ss12,Ss13,Ss14
  675. 6840 IF Pp>-1 THEN CALL Awrite(22,0,I$&" - "&Df$)
  676. 6850 RETURN
  677. 6860 ! ***************************************************************** !
  678. 6870 ! *                                                               * !
  679. 6880 ! *                          SET COMMAND                          * !
  680. 6890 ! *                                                               * !
  681. 6900 ! ***************************************************************** !
  682. 6910 S0: Rto=FNPval(S$,I$,Iv$,Rto,Pp)
  683. 6920 RETURN !   Timeout
  684. 6930 S1: Rlim=FNPval(S$,I$,Iv$,Rlim,Pp)
  685. 6940 RETURN ! Retry limit
  686. 6950 S2: Ps=FNLset(S$,Sc,Pp,Oo$,Sp$,I$,Io$)
  687. 6960 RETURN ! send conversion
  688. 6970 S3: Db=FNLset(S$,Db,Pp,Oo$,Sp$,I$,Io$)
  689. 6980 RETURN ! Debug (ON/OFF)
  690. 6990 S4: Pp=0
  691. 7000 IF LEN(S$)<>1 THEN
  692. 7010 I$=Ic$
  693. 7020 RETURN !  Prefix
  694. 7030  ELSE
  695. 7040 Sqctl$=S$
  696. 7050 RETURN
  697. 7060  END IF
  698. 7070 S5: Seol=FNPval(S$,I$,Iv$,Seol,Pp)
  699. 7080 RETURN ! End of line
  700. 7090 S6: T=0
  701. 7100 Db$="" !      Record end marker
  702. 7110 GOSUB Split
  703. 7120 Kk=FNPval(F$,I$,Iv$,0,Pp) ! Get no
  704. 7130 IF Kk=0 THEN RETURN !     If illegal RETURN
  705. 7140 Db$=Db$&CHR$(Kk)
  706. 7150 T=T+1 !  Add to Sstring
  707. 7160 IF (S$<>"") AND (T<4) THEN 7110! If more get no
  708. 7170 Re=T
  709. 7180 Re$=Db$
  710. 7190 Pp=7
  711. 7200 RETURN ! Set new value & RETURN
  712. 7210 S7: Fs=FNPval(S$,I$,Iv$,Fs,Pp)
  713. 7220 Nr=Fs*1024/Rl
  714. 7230 RETURN ! File size
  715. 7240 S8: Rl=FNPval(S$,I$,Iv$,Rl,Pp)
  716. 7250 Nr=Fs*1024/Rl
  717. 7260 RETURN ! Record length
  718. 7270 S9: Nr=FNPval(S$,I$,Iv$,Nr,Pp)
  719. 7280 Fs=Nr*Rl/1024
  720. 7290 RETURN ! No of records
  721. 7300 S10: Dx=FNLset(S$,Dx,Pp,Dx$,Sp$,I$,Io$)
  722. 7310 Le=Dx
  723. 7320 GOTO 7420 ! Duplex
  724. 7330 S11: Le=FNLset(S$,Le,Pp,Oo$,Sp$,I$,Io$)
  725. 7340 GOTO 7420 ! Local echo
  726. 7350 S12: Fc=FNLset(S$,Fc,Pp,Fc$,Sp$,I$,Io$)
  727. 7360 IF Fc<>0 THEN Hs=0! Flow control
  728. 7370 GOTO 7420
  729. 7380 S13: Hs=FNLset(S$,Hs,Pp,Hs$,Sp$,I$,Io$)
  730. 7390 IF Hs<>0 THEN Fc=0! Handshake
  731. 7400 GOTO 7420
  732. 7410 S14: Pt=FNLset(S$,Pt,Pp,Pt$,Sp$,I$,Io$) ! Parity
  733. 7420 GOSUB Rs_set
  734. 7430 RETURN ! Reset RS232
  735. 7440 !
  736. 7450 ! ***************************************************************** !
  737. 7460 ! *                                                               * !
  738. 7470 ! *                         SHOW COMMAND                          * !
  739. 7480 ! *                                                               * !
  740. 7490 ! ***************************************************************** !
  741. 7500 Sa: PRINT PAGE !             Clear screen
  742. 7510 FOR N=0 TO 14
  743. 7520 Nn=N+1 ! For each set option
  744. 7530   CALL Awrite(2+N DIV 2,40*(N MOD 2),FNXlist$((Sl$),Nn)) ! Display option
  745. 7540 ON Nn GOSUB Ss0,Ss1,Ss2,Ss3,Ss4,Ss5,Ss6,Ss7,Ss8,Ss9,Ss10,Ss11,Ss12,Ss13,Ss14
  746. 7550 CALL Awrite(2+N DIV 2,15+40*(N MOD 2),Df$)   !  Display value
  747. 7560 NEXT N
  748. 7570 RETURN
  749. 7580 Ss0: Df$=VAL$(Rto)
  750. 7590 RETURN ! Timeout
  751. 7600 Ss1: Df$=VAL$(Rlim)
  752. 7610 RETURN ! Retry limit
  753. 7620 Ss2: Df$=FNXlist$(Oo$,Sc+1)
  754. 7630 RETURN ! send conversion
  755. 7640 Ss3: Df$=FNXlist$(Oo$,Db+1)
  756. 7650 RETURN ! Debug
  757. 7660 Ss4: Df$=Sqctl$
  758. 7670 RETURN ! Prefix
  759. 7680 Ss5: Df$=VAL$(Seol)
  760. 7690 RETURN ! End of line
  761. 7700 Ss6: Df$="" ! Record end marker
  762. 7710 FOR I=1 TO Re
  763. 7720 Df$=Df$&VAL$(NUM(Re$[I,I]))&Sp$
  764. 7730 NEXT I
  765. 7740 RETURN
  766. 7750 Ss7: Df$=VAL$(Fs)&"k"
  767. 7760 RETURN ! File Ssize
  768. 7770 Ss8: Df$=VAL$(Rl)
  769. 7780 RETURN ! Record length
  770. 7790 Ss9: Df$=VAL$(Nr)
  771. 7800 RETURN ! No of records
  772. 7810 Ss10: Df$=FNXlist$(Dx$,Dx+1)
  773. 7820 RETURN ! Duplex
  774. 7830 Ss11: Df$=FNXlist$(Oo$,Le+1)
  775. 7840 RETURN ! Local echo
  776. 7850 Ss12: Df$=FNXlist$(Fc$,Fc+1)
  777. 7860 RETURN ! Flow control
  778. 7870 Ss13: Df$=FNXlist$(Hs$,Hs+1)
  779. 7880 RETURN ! Handshake
  780. 7890 Ss14: Df$=FNXlist$(Pt$,Pt+1)
  781. 7900 RETURN ! Parity
  782. 7910  ! ***************************************************************** !
  783. 7920  ! *                                                               * !
  784. 7930  ! *               SEND & RECEIVE SUBROUTINES                      * !
  785. 7940  ! *                                                               * !
  786. 7950  ! ***************************************************************** !
  787. 7960  !
  788. 7970  ! RECEIVE PACKET
  789. 7980  ! --------------
  790. 7990 Rec_pack:  Mm=0
  791. 8000  Id$="" !   Reset mark flag
  792. 8010  SET TIMEOUT 2;Tmo   ! Set timeout limit
  793. 8020 ! ON TIME OUT(2) GOTO Rto
  794. 8030 B_chk: !
  795. 8040  S=CSTAT(2,1)
  796. 8050  IF S=0 THEN
  797. 8060  WAIT Tmo/5
  798. 8070  GOTO B_chk  ! If no data wait & check again
  799. 8080  END IF
  800. 8090  CREAD 2;Ibuff$
  801. 8100    I$=Ibuff$
  802. 8110  Ll=LEN(I$)
  803. 8120  Ii=1 ! Data length & count
  804. 8130 N_chr:  Kk$=I$[Ii,Ii] !   Get character
  805. 8140  IF Kk$=Mk$ THEN
  806. 8150  Mm=1
  807. 8160  Rp$=""
  808. 8170  Jj=0 !  If mark set flag, null packet etc
  809. 8180  END IF
  810. 8190  IF Mm=0 THEN I_chr !   Mark not reached yet skip
  811. 8200  IF Kk$=Reol$ THEN E_pck !   End line recieved
  812. 8210  Rp$=Rp$&Kk$
  813. 8220  Jj=Jj+1 !  Add char to packet inc count
  814. 8230 I_chr:  Ii=Ii+1
  815. 8240    IF Ii>Ll THEN
  816. 8250  GOTO B_chk
  817. 8260  ELSE
  818. 8270  GOTO N_chr ! if no data in buf get more
  819. 8280  END IF
  820. 8290 E_pck:  IF Jj<5 THEN 8030  ! packet not long enough get another
  821. 8300  ! OFF TIMER# 1 ! Halt timer
  822. 8310  IF Ii<Ll THEN Ibuff$=I$[Ii+1,Ll]&Ibuff$ !If data in I$ replace in buffer
  823. 8320  IF Db=1 THEN CALL Awrite(Rrr,Rc,Rp$)   !  display packet if debug on
  824. 8330  Cc$=FNCbyte$((Rp$[2,Jj-1]))!  Calculate check byte | if wrong
  825. 8340  IF Cc$<>Rp$[Jj,Jj] THEN
  826. 8350  Rt$=FNStbit$((Rp$[Jj]))
  827. 8360  Bp=Bp+1
  828. 8370  RETURN ! set B7 type
  829. 8380  END IF
  830. 8390  Rt$=Rp$[4,4]
  831. 8400  Rn=FNUnchar((Rp$[3,3]))! Get type & sequence number
  832. 8410  Ff=0
  833. 8420  FOR Ii=5 TO Jj-1
  834. 8430  Kk$=Rp$[Ii,Ii] ! Get each charcter in data part
  835. 8440  IF Ff=0 THEN 8480  !   If prefix flag off skip
  836. 8450  IF Kk$<>Rqctl$ THEN Kk$=FNCtl$(Kk$)! If not prefix char change to ctRl
  837. 8460  Ff=0
  838. 8470  GOTO 8520  ! Skip to add to data string
  839. 8480  IF Kk$=Rqctl$ THEN
  840. 8490  Ff=1
  841. 8500  GOTO 8530  ! If prefix char set flag next char
  842. 8510  END IF
  843. 8520  Id$=Id$&Kk$ !   Add char to data string
  844. 8530  NEXT Ii
  845. 8540  RETURN ! RETURN
  846. 8550 Rto:   ! OFF TIMER# 1 !   Disable timer
  847. 8560  IF Mm=1 THEN
  848. 8570  Mm=2
  849. 8580  GOTO 8010  ! Packet is being transmitted wait
  850. 8590  END IF
  851. 8600  ! IF Hs#0 THEN RESUME 10 !   If handshake enable transmit
  852. 8610  Ttmo=Ttmo+1
  853. 8620  Rt$="T"
  854. 8630  RETURN
  855. 8640  !
  856. 8650  ! SEND PACKET
  857. 8660  ! -----------
  858. 8670 Send_pack:  Ff=0
  859. 8680  Rr=0
  860. 8690  GOSUB C_pack  ! Set flag & retry, construct packet
  861. 8700 Send1:  Ss=T
  862. 8710  GOSUB Disp_state  ! Display state
  863. 8720  IF Db THEN
  864. 8730  CALL Awrite(Sr,0,RPT$(Sp$,320))
  865. 8740  CALL Awrite(Sr,Ssc,Op$)   ! debug display
  866. 8750  END IF
  867. 8760  GOSUB Send_buff
  868. 8770  IF Ff<>0 THEN RETURN ! Send buffer out
  869. 8780  Ss=6
  870. 8790  GOSUB Disp_state
  871. 8800  GOSUB Rec_pack  ! Display, receive ACK/NAK
  872. 8810  IF (Rt$>Del$) OR (Rt$=Tm$) THEN 8950 ! Bad packet or timeout retry ?
  873. 8820  N=BINAND(Rn-BINAND(Nn,63),63)
  874. 8830  Ff=0 !  Find seq no difference
  875. 8840  IF (Rt$=Ak$) AND (N=0) OR (Rt$=Nk$) AND (N=1) THEN
  876. 8850  Pc=Nn=Nn+1
  877. 8860  RETURN ! Ok RETURN
  878. 8870  END IF
  879. 8880  IF (Rt$=Ak$) AND (N=63) THEN 8780 ! Previous ACK - Ignore
  880. 8890  IF Rt$<>Nk$ THEN
  881. 8900  Ff=4
  882. 8910    RETURN              ! If not nak - wrong packet
  883. 8920  ELSE
  884. 8930  Nk=Nk+1
  885. 8940  END IF
  886. 8950  Rr=Rr+1
  887. 8960  IF Rr<Rlim THEN Send1 !  If retry  < limit send again
  888. 8970  IF Rt$=Tm$ THEN
  889. 8980  Ff=1
  890. 8990  RETURN !  Timeout error
  891. 9000  END IF
  892. 9010  IF Rt$=Nk$ THEN    !   NAK error
  893. 9020  Ff=2
  894. 9030  ELSE
  895. 9040  Ff=3
  896. 9050  END IF
  897. 9060  RETURN
  898. 9070  !
  899. 9080  ! CONSTRUCT PACKET
  900. 9090  ! ----------------
  901. 9100 C_pack:  Op$=FNChar$(BINAND(Nn,63))&T$&Od$  !  Add seq & type to data
  902. 9110  Op$=FNChar$(LEN(Op$)+1)&Op$  !   Add length to data
  903. 9120  Op$=Mk$&Op$&FNCbyte$(Op$) ! Add mark & check byte
  904. 9130  IF Snpad>0 THEN Obuff$=RPT$(Spadc$,Snpad)  ! Add padding if needed
  905. 9140  Obuff$=TRIM$(Op$&CHR$(Seol))
  906. 9150  Bl=CSTAT(2,2)
  907. 9160  RETURN !   Get buffer length
  908. 9170  !
  909. 9180  !  CLEAR  INPUT BUFFER CONTENTS
  910. 9190 Clrbuf: CREAD 2;Resp$
  911. 9200  IF Resp$<>"" THEN Clrbuf
  912. 9210  RETURN
  913. 9220  !
  914. 9230  !  TRANSMIT BUFFER CONTENTS
  915. 9240 Send_buff:  !  ------------------------
  916. 9250  SET TIMEOUT 2;Stm
  917. 9260 ! ON TIME OUT(2) GOTO 9780
  918. 9270  GOSUB Clrbuf
  919. 9280  CWRITE 2;Obuff$
  920. 9290  SET TIMEOUT 2;32767
  921. 9300  Ibuff$="" !  Disable timer & clear input buffer
  922. 9310  RETURN
  923. 9320  Ff=5
  924. 9330  ! OFF TIMER# 1
  925. 9340  RETURN !  Set error flag
  926. 9350  !
  927. 9360  ! RECEIVE PACKET WITH ACK
  928. 9370  ! -----------------------
  929. 9380 Get_pack:  Rr=0
  930. 9390  Ss=T
  931. 9400  GOSUB Disp_state
  932. 9410  CALL Awrite(Rrr,0,RPT$(Sp$,320))    ! Display
  933. 9420  Ff=Pp=0
  934. 9430  GOSUB Rec_pack  ! Receive packet
  935. 9440  IF Rt$=Tm$ THEN
  936. 9450  Ff=1
  937. 9460  GOTO 9660  ! If timeout retry ?
  938. 9470  END IF
  939. 9480  IF Rt$>Del$ THEN
  940. 9490   Ff=3
  941. 9500  GOTO 9660  !  If checksum error retry
  942. 9510  END IF
  943. 9520  Pp=POS(A$,Rt$)
  944. 9530  N=BINAND(Rn-Nn,63)  !  Is received type valid
  945. 9540  IF (N<>0) AND (N<>63) OR (Pp=0) THEN
  946. 9550  Ff=4
  947. 9560  RETURN ! If not valid exit
  948. 9570  END IF
  949. 9580  Od$=""
  950. 9590  IF Rt$=Si$ THEN Od$=In$ ! If SEND-INIT set INIT ACK
  951. 9600  T$=Ak$
  952. 9610  Ss=6
  953. 9620  Nn=Rn
  954. 9630  GOSUB C_pack  !  Construct ACK
  955. 9640  Nn=(Nn+1) MOD 64
  956. 9650  GOTO 9730  !  Get next seq - Send ACK
  957. 9660  Rr=Rr+1
  958. 9670  IF Rr>Rlim THEN RETURN ! If retry limit exceeded exit
  959. 9680  T$=Nk$
  960. 9690  Ss=7
  961. 9700  Od$=""
  962. 9710  Nk=Nk+1
  963. 9720  GOSUB C_pack  ! Construct NAK
  964. 9730  GOSUB Disp_state
  965. 9740  IF Db THEN CALL Awrite(Sr,Ssc,Op$)   !  Display state
  966. 9750  Ff=0
  967. 9760  GOSUB Send_buff
  968. 9770  IF Ff<>0 THEN RETURN ! Send ACK/NAK
  969. 9780  IF (Pp<>1) AND (Pp<>2) OR (N<>0) THEN 9390 !  If not valid get another packet
  970. 9790  Pc=Pc+1
  971. 9800  RETURN ! Inc packet count - RETURN
  972. 9810  ! ***************************************************************** !
  973. 9820  ! *                                                               * !
  974. 9830  ! *           CONSTRUCT & DECODE INITIALISATION PACKETS           * !
  975. 9840  ! *                                                               * !
  976. 9850  ! ***************************************************************** !
  977. 9860  !
  978. 9870  !   SET UP SEND-INIT PACKET (S(0),Y(0))
  979. 9880  !   -----------------------------------
  980. 9890 Init_pack:  Ttmo=Nk=Bp=0 !   Timeouts naks & bad packets
  981. 9900  Tmo=Rto*1000 !      Set timeout for receiving
  982. 9910  In$=FNChar$(Rmaxl) !   Packet = maximum length
  983. 9920    In$=In$&FNChar$(Sto) ! + send timeout
  984. 9930  In$=In$&FNChar$(Rnpad)&FNCtl$(Rpadc$) ! + no of pad chars & char
  985. 9940  In$=In$&FNChar$(Seol)&Sqctl$ !  + end of line & ctRl qoute
  986. 9950  Smaxl=80
  987. 9960  Snpad=0
  988. 9970  Spadc$=Null$
  989. 9980  Reol=13
  990. 9990  Rqctl$="#" ! Defaults
  991. 10000 RETURN
  992. 10010 !
  993. 10020 ! EXTRACT PARAMETERS FROM INIT PACKET (S(0),Y(0))
  994. 10030 ! -----------------------------------------------
  995. 10040 Dcd_init: Ll=LEN(Rp$)-5
  996. 10050 IF Ll=0 THEN RETURN ! If no params RETURN
  997. 10060 IF Ll<7 THEN  ! Change params
  998. 10070 ON Ll GOTO Maxl,Tmo,Npad,Padc,Elc,Qctl
  999. 10080 END IF
  1000. 10090 Qctl: IF Rp$[10,10]<>Sp$ THEN Rqctl$=Rp$[10,10]!  Prefix char
  1001. 10100 Elc: IF Rp$[9,9]<>Sp$ THEN Seol=FNUnchar((Rp$[9,9]))! End of line
  1002. 10110 Padc: IF Rp$[8,8]<>Sp$ THEN Spadc$=FNCtl$((Rp$[8,8]))!  Pad character
  1003. 10120 Npad: IF Rp$[7,7]<>Sp$ THEN Snpad=FNUnchar((Rp$[7,7]))! No of pad chars
  1004. 10130 Tmo: IF Rp$[6,6]<>Sp$ THEN Rto=FNUnchar((Rp$[6,6]))!  Receive timeout
  1005. 10140 Maxl: IF Rp$[5,5]<>Sp$ THEN Smaxl=FNUnchar((Rp$[5,5]))! Max packet length
  1006. 10150 RETURN
  1007. 10160 !
  1008. 10170 !  EXIT ROUTINE FOR SEND & RECEIVE
  1009. 10180 !  -------------------------------
  1010. 10190 Srexit: IF (Ff=0) OR (Ff=5) THEN 10280!  If ok or send problem skip
  1011. 10200 IF (Ff<>4) OR (Rt$<>Er$) THEN 10230!  If not error packet skip
  1012. 10210 CALL Awrite(19,0,"Error message from remote - "&Id$)
  1013. 10220 GOTO 10310! Display
  1014. 10230 Od$=Em$(Ff)
  1015. 10240 T$=Er$
  1016. 10250 T=5 ! Set up error packet
  1017. 10260 GOSUB C_pack
  1018. 10270 GOSUB Send_buff  !  Construct and send error packet
  1019. 10280 CALL Awrite(19,0,Em$(Ff))   !   Display message (ok or error)
  1020. 10290   BEEP !(Ff#1)*20+20,200 ! Beep (lower for error)
  1021. 10300   IF (Ff>6) AND (Ff<23) THEN CALL Awrite(19,LEN(Em$(Ff))+1,"(error no - "&VAL$(Ee)&")")
  1022. 10310 CCONTROL 2;READALL OFF
  1023. 10320 RETURN !        RETURN to command section
  1024. 10330 !
  1025. 10340 ! ABORT TRANSFER
  1026. 10350 ! --------------
  1027. 10360 Abort: Ff=24
  1028. 10370 RETURN ! Set error flag to abort
  1029. 10380 ! **************************************************************** !
  1030. 10390 !
  1031. 10400 !   SET UP RS232 INTERFACE
  1032. 10410 !   ----------------------
  1033. 10420 ! **************************************************************** !
  1034. 10430 Rs_set: CDISCONNECT 2;HOLD
  1035. 10440 !  CCOM 4428
  1036. 10450 CMODEL ASYNC,2;ALERTN=1,CHECK=1,MEMLIMIT=2000,INBUFFER=1240,TBUFFER=520
  1037. 10460 CCONNECT 2;HANDSHAKE OFF,SPEED=9600
  1038. 10470 CCONTROL 2;XON
  1039. 10480 CWRITE 2;ENDLINE
  1040. 10490 SYSTEM TIMEOUT OFF
  1041. 10500 SET TIMEOUT 2;32767
  1042. 10510 RETURN
  1043. 10520 !
  1044. 10530 ! DUMMY SUBROUTINE
  1045. 10540 ! ----------------
  1046. 10550 Dummy: RETURN
  1047. 10560 !
  1048. 10570 ! SET UP KEYS TO DUMMY ROUTINE
  1049. 10580 ! ----------------------------
  1050. 10590 Dkeys: FOR Ii=1 TO 14
  1051. 10600 ON KEY #Ii GOSUB Dummy
  1052. 10610 NEXT Ii
  1053. 10620 RETURN
  1054. 10630 ! ******************************************************************** !
  1055. 10640 ! *                                                                  * !
  1056. 10650 ! *         ROUTINES FOR DISPLAYING CURRENT SENDING STATE            * !
  1057. 10660 ! *                                                                  * !
  1058. 10670 ! ******************************************************************** !
  1059. 10680 ! #   The following variables are used by these routines
  1060. 10690 ! #   S   - State (0/1) sending or waiting for ACK
  1061. 10700 ! #   T   - Type of packet being sent (0-S,1-F,2-D,3-Z,4-B)
  1062. 10710 ! #   Nn   - Current sequence number (not modulo 64)
  1063. 10720 ! #   Rr   - No of retries for current packet
  1064. 10730 ! #   Nk  - No of NAKs received
  1065. 10740 ! #   Tm  - No of timeouts
  1066. 10750 ! #   Bp  - No of corrupted packets received
  1067. 10760 ! #   Kk   - No of bytes sent
  1068. 10770 ! #   Sf$ - Source      file specifier
  1069. 10780 ! #   Df$ - Destination  ''     ''
  1070. 10790 !
  1071. 10800 ! SET UP SCREEN FOR SEND DISPLAY
  1072. 10810 ! ------------------------------
  1073. 10820 Dsend: PRINT PAGE
  1074. 10830 CALL Awrite(1,2,"HP98 Kermit - "&St$(St)&" file")
  1075. 10840 CALL Awrite(2,2,RPT$("-",LEN(St$(St))+19))
  1076. 10850 IF St=0 THEN CALL Awrite(4,2,St$(St)&" "&Sf$&" as "&Df$)
  1077. 10860 CALL Awrite(6,2,"Current action :")
  1078. 10870 CALL Awrite(6,46,"Retries :")
  1079. 10880 CALL Awrite(8,2,"Packets          :")
  1080. 10890 CALL Awrite(8,40,"NAKs          :")
  1081. 10900 CALL Awrite(9,2,"Bytes            :")
  1082. 10910 CALL Awrite(9,40,"Timeouts      :")
  1083. 10920 CALL Awrite(10,40,"Bad packets   :")
  1084. 10930 CALL Awrite(8,10,St$(St))
  1085. 10940 CALL Awrite(8,45,St$(1-St))
  1086. 10950 CALL Awrite(9,8,St$(St))
  1087. 10960 RETURN
  1088. 10970 !
  1089. 10980 ! DISPLAY SENDING STATE
  1090. 10990 ! ---------------------
  1091. 11000 Disp_state: Tt=(Ss>7) OR (Ss=6) AND (St=0) OR (Ss=0) AND (St=1)!Wait or Send (1/0)
  1092. 11010 IF Tt THEN
  1093. 11020 D$="Wait for "
  1094. 11030 ELSE
  1095. 11040 D$="Send "
  1096. 11050 END IF
  1097. 11060 CALL Awrite(6,18,RPT$(Sp$,26))    ! Clear old action
  1098. 11070 CALL Awrite(6,18,D$&A$(Ss))
  1099. 11080 CALL Awrite(6,56,VAL$(Rr))    ! Display action & Retries
  1100. 11090 CALL Awrite(8,21,VAL$(Pc))
  1101. 11100 CALL Awrite(8,56,VAL$(Nk))    !  Packets & NAKs
  1102. 11110 CALL Awrite(9,21,FNKb$(Kk))
  1103. 11120 CALL Awrite(9,56,VAL$(Ttmo))    ! Bytes & timeouts
  1104. 11130 CALL Awrite(10,56,VAL$(Bp))    !  Bad packets received
  1105. 11140 RETURN
  1106. 11150 ! **************************************************************** !
  1107. 11160 ! *                                                              * !
  1108. 11170 ! *              SUBROUTINES FOR DISK ACCESS                     * !
  1109. 11180 ! *                                                              * !
  1110. 11190 ! **************************************************************** !
  1111. 11200 !
  1112. 11210 ! OPEN FILE FOR READING
  1113. 11220 ! ---------------------
  1114. 11230 Open_read: ON ERROR GOTO Fserr
  1115. 11240 SELECT Data_type
  1116. 11250 CASE 1
  1117. 11260 ASSIGN #1 TO Sf$  ! Try to open file
  1118. 11270 CASE 2
  1119. 11280 CALL Samfile(Sig(*),Sig1(*),1,Info$(*),File$,Title$,Line1$,Line2$,Line3$,Sf$)
  1120. 11290 Span=VAL(Info$(2))
  1121. 11300 END SELECT
  1122. 11310 OFF ERROR
  1123. 11320 Ff=0
  1124. 11330 RETURN !    If success RETURN
  1125. 11340 !
  1126. 11350 !  GET PACKET OF DATA FROM FILE
  1127. 11360 !  ----------------------------
  1128. 11370 Get_data: Bb=0
  1129. 11380 Ll=LEN(Db$)
  1130. 11390 IF Ll>=Minl THEN 12000  !   If enough data output
  1131. 11400 IF Data_type=2 THEN 11550
  1132. 11410 ON ERROR GOTO 12140 ! Set 8-bit data flag
  1133. 11420 Tt=TYP(1)
  1134. 11430 IF Tt<>3 THEN 11520! Not EOF get more data
  1135. 11440 Ee=1
  1136. 11450 OFF ERROR !        Error trap off
  1137. 11460 IF Ll=0 THEN       ! Get any data left
  1138. 11470 Od$=""
  1139. 11480 RETURN
  1140. 11490 ELSE
  1141. 11500   GOTO 12010
  1142. 11510 END IF
  1143. 11520 IF Tt=1 THEN 11870 !      If number skip
  1144. 11530 READ #1;S$
  1145. 11540 GOTO 11630
  1146. 11550 IF Sigj<=Span THEN 11620
  1147. 11560 IF Ll=0 THEN
  1148. 11570 Od$=""
  1149. 11580 RETURN
  1150. 11590 ELSE
  1151. 11600 GOTO 12010
  1152. 11610 END IF
  1153. 11620 CALL Encode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Sig(*),Sigj,Line_no,Rmaxl,Span,Sig0)
  1154. 11630 S$=S$&Re$
  1155. 11640 L=LEN(S$)
  1156. 11650 Kk=Kk+L ! Read string variable
  1157. 11660 FOR Ii=1 TO L
  1158. 11670 Kk$=S$[Ii,Ii] ! Get character
  1159. 11680   IF Kk$<=Del$ THEN    !  If 8-bit reset b7
  1160. 11690   GOTO 11780
  1161. 11700   ELSE
  1162. 11710   Kk$=FNStbit$(Kk$)
  1163. 11720   END IF
  1164. 11730 IF Bb=0 THEN
  1165. 11740 PRINT "Eight bit data"
  1166. 11750 BEEP
  1167. 11760 Bb=1 ! WaRn if first 8-bit
  1168. 11770 END IF
  1169. 11780 IF Kk$<Sp$ THEN
  1170. 11790 Db$=Db$&Sqctl$
  1171. 11800 Kk$=FNCtl$(Kk$) !  If ctRl prefix
  1172. 11810 END IF
  1173. 11820 IF Kk$=Sqctl$ THEN Db$=Db$&Kk$ !  If prefix prefix
  1174. 11830 Db$=Db$&Kk$
  1175. 11840 NEXT Ii
  1176. 11850 GOTO 11380 !   Add char to buffer
  1177. 11860 IF Sc=0 THEN
  1178. 11870 Ff=23
  1179. 11880 RETURN ! If no conversion - error
  1180. 11890 END IF
  1181. 11900 SELECT Data_type
  1182. 11910 CASE 1
  1183. 11920 READ #1,S
  1184. 11930 CASE 2
  1185. 11940 CALL Encode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Sig(*),Sigj,Line_no,Rmaxl,Span,Sig0)
  1186. 11950 END SELECT
  1187. 11960 S$=VAL$(S)  !  Convert no to string
  1188. 11970 Db$=Db$&Sp$&S$
  1189. 11980 Kk=Kk+LEN(S$)+1
  1190. 11990 GOTO 11380 ! Add no to buffer
  1191. 12000 OFF ERROR !              Stop error trap
  1192. 12010 IF Ll<=Maxl THEN
  1193. 12020 Od$=Db$
  1194. 12030 Db$=""
  1195. 12040 RETURN ! If amount<max output
  1196. 12050 END IF
  1197. 12060 S=Maxl !                 Get split position
  1198. 12070 IF Db$[S,S]=Sqctl$ THEN
  1199. 12080 S=S-1
  1200. 12090 GOTO 12070 ! If prefix move split
  1201. 12100 END IF
  1202. 12110 Od$=Db$[1,S]
  1203. 12120 Db$=Db$[S+1,Ll] ! Split data save rest
  1204. 12130 RETURN
  1205. 12140 OFF ERROR
  1206. 12150 IF (ERRN=59) OR (ERRN=60) THEN 11440! End of file
  1207. 12160 IF ERRN=65 THEN
  1208. 12170 Ff=23
  1209. 12180 RETURN !  Data type error
  1210. 12190 END IF
  1211. 12200 GOTO Fserr  !            Goto error routine
  1212. 12210 !
  1213. 12220 ! CREATE & OPEN FILE FOR WRITING
  1214. 12230 ! ------------------------------
  1215. 12240 Open_write: Ff=0 !  Set error flag
  1216. 12250 IF Df$<>Pf$ THEN
  1217. 12260 Nf=0
  1218. 12270 GOTO 12340 ! If new name reset count skip
  1219. 12280 END IF
  1220. 12290 IF Nf>99 THEN
  1221. 12300 Ff=6
  1222. 12310 RETURN !  If cannot renumber -exit
  1223. 12320 END IF
  1224. 12330 Df$=FNNofile$(Df$,Nf,Ft,Pp,Np) ! Renumber file
  1225. 12340 ON ERROR GOTO Fserr  !  Set filing system error trap
  1226. 12350 IF Data_type<>1 THEN 12380
  1227. 12360 CREATE Df$,Nr,Rl ! Try to create file
  1228. 12370 ASSIGN #1 TO Df$  !  If successfull open file
  1229. 12380 OFF ERROR
  1230. 12390 Pf$=Df$ !   Save name
  1231. 12400 RETURN
  1232. 12410 !
  1233. 12420 !  WRITE DATA TO FILE
  1234. 12430 !  ------------------
  1235. 12440 Put_data:  SELECT Data_type
  1236. 12450   CASE 1
  1237. 12460 Db$=Db$&Id$
  1238. 12470 Kk=Kk+LEN(Id$)  ! Place data in buffer
  1239. 12480 ON ERROR GOTO Fserr  ! Set error trap
  1240. 12490 Pp=POS(Db$,Re$)  !  Find end of record
  1241. 12500 IF Pp=0 THEN
  1242. 12510 OFF ERROR
  1243. 12520 RETURN !  IF no EOR exit
  1244. 12530 END IF
  1245. 12540   IF Pp>1 THEN  !  If data before EOR get it
  1246. 12550   S$=Db$[1,Pp-1]
  1247. 12560   ELSE
  1248. 12570   S$=""
  1249. 12580   END IF
  1250. 12590 PRINT #1;S$
  1251. 12600 Ll=LEN(Db$)  !   Output to disk, find buff length
  1252. 12610   IF Ll>Pp+(Re-1) THEN                 ! If any data left save
  1253. 12620   Db$=Db$[Pp+Re]
  1254. 12630   ELSE
  1255. 12640   Db$=""
  1256. 12650   END IF
  1257. 12660 GOTO 12490
  1258. 12670 CASE 2
  1259. 12680 Db$=Id$
  1260. 12690 S$=Db$
  1261. 12700 CALL Decode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Left$,Sig(*),Sigj,Line_no,Pp,Inf,Sig0)
  1262. 12710 Db$=""
  1263. 12720 END SELECT
  1264. 12730 RETURN
  1265. 12740 !
  1266. 12750 ! CLOSE FILE
  1267. 12760 ! ----------
  1268. 12770 Close_write: ON ERROR GOTO Fserr  !   Set up error trap
  1269. 12780 IF LEN(Db$)>0 THEN
  1270. 12790 SELECT Data_type
  1271. 12800 CASE 1
  1272. 12810 PRINT #1;Db$
  1273. 12820 Db$="" ! Write any remaining data
  1274. 12830 ASSIGN #1 TO *  !     Close file
  1275. 12840 CASE 2
  1276. 12850 CALL Decode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Left$,Sig(*),Sigj,Line_no,Pp,Inf,Sig0)
  1277. 12860 Db$=""
  1278. 12870 PRINT "File ready to be stored"
  1279. 12880 PAUSE
  1280. 12890 ! CALL Samfile(Sig(*),Sig1(*),2,Span,Info$(*),File$,Title$,Line1$,Line2$,Line3$,Sf$,Df$)
  1281. 12900 END SELECT
  1282. 12910 END IF
  1283. 12920 OFF ERROR
  1284. 12930 RETURN
  1285. 12940 !
  1286. 12950 ! FILING SYSTEM ERROR HANDLING ROUTINE
  1287. 12960 ! ------------------------------------
  1288. 12970 Fserr: Ee=ERRN
  1289. 12980 Ll=ERRL
  1290. 12990 OFF ERROR ! Get error no & line no
  1291. 13000 IF (Ee=54) AND (Ll=12360) THEN 12290! If DUP NAME & CREATE -retry new name
  1292. 13010 Pp=POS(Fse$,CHR$(Ee))   !  Find pos of error in valid string
  1293. 13020 IF Pp>0 THEN
  1294. 13030 Ff=6+Pp
  1295. 13040 RETURN ! If valid error - set flag & RETURN
  1296. 13050 END IF
  1297. 13060 RESUME INTERACTIVE
  1298. 13070 PRINT "UNEXPECTED ERROR !"
  1299. 13080   PRINT USING "6A,K,9A,K";"ERROR ",Ee," AT LINE ",Ll
  1300. 13090 END
  1301. 13100 !
  1302. 13110 ! **************************************************************** !
  1303. 13120 ! *                                                              * !
  1304. 13130 ! *          FUNCTIONS FOR CODING & DECODING PACKETS             * !
  1305. 13140 ! *                                                              * !
  1306. 13150 ! **************************************************************** !
  1307. 13160 !
  1308. 13170 ! CONVERT NUMBER TO PRINTABLE CHARACTER
  1309. 13180 ! -------------------------------------
  1310. 13190 Char:DEF FNChar$(INTEGER Nn)=CHR$(Nn+32)    !  Character = no + 32
  1311. 13200 !
  1312. 13210 ! CONVERT CHARACTER TO NUMBER
  1313. 13220 ! ---------------------------
  1314. 13230 Unchar:DEF FNUnchar(Cc$)=NUM(Cc$)-32    ! no = char - 32
  1315. 13240 !
  1316. 13250 !  SWAP BETWEEN CONTROL CHARACTER AND PRINTABLE CHARACTER
  1317. 13260 !  ------------------------------------------------------
  1318. 13270 Ctl:DEF FNCtl$(Cc$)=CHR$(BINEOR(NUM(Cc$),64))      ! xor bit 6
  1319. 13280 !
  1320. 13290 !   SET / RESET TOP BYTE OF CHARACTER
  1321. 13300 !   ---------------------------------
  1322. 13310 Stbit:DEF FNStbit$(Cc$)=CHR$(BINEOR(NUM(Cc$),128))      ! xor bit 7
  1323. 13320 ! FUNCTION TO RENUMBER FILE
  1324. 13330 !  -------------------------
  1325. 13340 Nofile:DEF FNNofile$(F$,INTEGER Nf,Ft,Pp,Np)
  1326. 13350 IF Nf>0 THEN 13430 !  If Not first numbering skip
  1327. 13360 IF Ft<2 THEN 13410 !  If Not Fn Ft format skip
  1328. 13370   Np=Pp=Ft
  1329. 13380 IF Np>5 THEN Np=5 !  Find position of Ft
  1330. 13390 F$[Np]="00"&F$[Pp]
  1331. 13400 GOTO 13440 ! Insert 00
  1332. 13410 Np=LEN(F$)+1
  1333. 13420 IF Np>9 THEN Np=9 !  Find position of no
  1334. 13430 F$[Np,Np+1]=VAL$(Nf DIV 10)&VAL$(Nf MOD 10)
  1335. 13440 Nf=Nf+1
  1336. 13450 RETURN F$ ! Inc count RETURN new name
  1337. 13460 FNEND
  1338. 13470 !
  1339. 13480 ! FUNCTION TO CHECK FOR "c..."
  1340. 13490 ! ----------------------------
  1341. 13500 Fsplit:DEF FNFsplit(F$,Q$,INTEGER Ll)
  1342. 13510 Pp=0
  1343. 13520 Ll=LEN(F$)  !  Set p  get length of string
  1344. 13530 IF Ll<3 THEN 13570 ! Must be at least "?" (? - any char)
  1345. 13540 IF F$[1,1]<>Q$ THEN 13570!   Must start with "
  1346. 13550 Pp=POS(F$[2],Q$)
  1347. 13560 IF Pp<2 THEN Pp=0 ! Find position of next " ("" invalid)
  1348. 13570 RETURN Pp ! RETURN position
  1349. 13580 FNEND
  1350. 13590 !
  1351. 13600 !  FIND POSITION OF OPTION IN LIST OF VALID OPTIONS
  1352. 13610 !  ------------------------------------------------
  1353. 13620 Inlist:DEF FNInlist(Cc$,Ll1$,Sp$)
  1354. 13630 DIM Ll$[164]
  1355. 13640 Ll$=Ll1$
  1356. 13650 Cc$=UPC$(Cc$)
  1357. 13660 Ll=Jj=1
  1358. 13670 L=LEN(Ll$)  ! Cc$ - uppercase, set count etc
  1359. 13680 IF Cc$<>"?" THEN 13990!   If not '?' skip
  1360. 13690 Jj=-1
  1361. 13700 IF L<68 THEN
  1362. 13710 P=L
  1363. 13720 GOTO 13850 !  If list fits display
  1364. 13730 END IF
  1365. 13740 CALL Awrite(22,0,RPT$(Sp$,160))    !  Clear screen area
  1366. 13750 Pp=POS(Ll$[Ll],", ")  ! Find ', '
  1367. 13760 IF Pp=0 THEN
  1368. 13770  P=L
  1369. 13780 GOTO 13850 ! If end skip
  1370. 13790 END IF
  1371. 13800 Ll=Ll+Pp
  1372. 13810 IF Ll<68 THEN
  1373. 13820 P=Ll-1
  1374. 13830 GOTO 13740 ! If fits get next
  1375. 13840 END IF
  1376. 13850 CALL Awrite(22,0,"Options :- "&Ll$[1,P])
  1377. 13860 IF P=L THEN 14110 ! display
  1378. 13870 Ll$=Ll$[P+2]
  1379. 13880 L=L-P-1
  1380. 13890 Ll=1
  1381. 13900 CALL Awrite(23,0,"Press CONT for more")   !
  1382. 13910 ! Kk$=KBD$
  1383. 13920 ! IF Kk$="" THEN  !  wait for key
  1384. 13930 ! GOTO 14110
  1385. 13940 ! ELSE
  1386. 13950 ! GOTO 13940
  1387. 13960 ! END IF
  1388. 13970 INPUT "",Dum
  1389. 13980 GOTO 13740
  1390. 13990 Cp=POS(Ll$[Ll],",")  ! Find pos of ','
  1391. 14000   IF Cp>0 THEN                      !  Adjust - if at end pos = end
  1392. 14010  Cp=Cp+Ll-1
  1393. 14020  ELSE
  1394. 14030  Cp=L
  1395. 14040  END IF
  1396. 14050 Pp=POS(Ll$[Ll,Cp],Cc$)
  1397. 14060 IF Pp=1 THEN 14110 ! Is Cc$ same as part of option
  1398. 14070 Jj=Jj+1
  1399. 14080 Ll=Cp+2
  1400. 14090 IF Ll<L THEN 13990 !  Find next option
  1401. 14100 Jj=0 !             If no more illegal option
  1402. 14110 RETURN Jj
  1403. 14120 FNEND
  1404. 14130 !
  1405. 14140 !  FUNCTION TO CONVERT STRING TO NO
  1406. 14150 !  --------------------------------
  1407. 14160 Pval:DEF FNPval(Cc$,I$,Iv$,INTEGER Oo,Pp)
  1408. 14170 IF Cc$<>"?" THEN 14210! If not ? get value
  1409. 14180 Df$="value"
  1410. 14190 Pp=0 !  On RETURN OPTION - value will be printed
  1411. 14200 GOTO 14280
  1412. 14210 Cc=NUM(Cc$)  !  Check for numeric (0-9)
  1413. 14220 IF (Cc<48) OR (Cc>58) THEN
  1414. 14230 I$=Iv$
  1415. 14240 Pp=0
  1416. 14250 GOTO 14280 ! Illegal value ?
  1417. 14260 END IF
  1418. 14270 Oo=VAL(Cc$)  !  Set new value
  1419. 14280 RETURN Oo !  RETURN value (If error then old value RETURNed)
  1420. 14290 FNEND
  1421. 14300 !
  1422. 14310 ! SET VARIABLE FROM LIST
  1423. 14320 ! ----------------------
  1424. 14330 Lset:DEF FNLset(Cc$,INTEGER Oo,Pp,Ll$,Sp$,I$,Io$)
  1425. 14340 Pp=FNInlist(Cc$,Ll$,Sp$)
  1426. 14350   IF Pp<1 THEN
  1427. 14360  I$=Io$
  1428. 14370  ELSE
  1429. 14380  Oo=Pp-1
  1430. 14390  END IF
  1431. 14400 RETURN Oo
  1432. 14410 FNEND
  1433. 14420 !
  1434. 14430 !  DISPLAY OPTION FROM LIST
  1435. 14440 !  ------------------------
  1436. 14450 Xlist: DEF FNXlist$(Ll$,INTEGER Pp)
  1437. 14460 Jj=1
  1438. 14470 Ll=1
  1439. 14480 L=LEN(Ll$)  ! Set count, last pos & length
  1440. 14490 Cp=POS(Ll$[Ll],", ")  !   Position of ', '
  1441. 14500   IF Cp>0 THEN                      !   Set cp to end of option
  1442. 14510  Cp=Cp+Ll-2
  1443. 14520  ELSE
  1444. 14530  Cp=L
  1445. 14540  END IF
  1446. 14550 IF Jj=Pp THEN
  1447. 14560 RETURN Ll$[Ll,Cp]
  1448. 14570 GOTO 14620
  1449. 14580 END IF
  1450. 14590 Jj=Jj+1
  1451. 14600 Ll=Cp+3
  1452. 14610 IF Ll<L THEN 14490 ! Get next option
  1453. 14620 RETURN "" !        If end of list RETURN null
  1454. 14630   FNEND
  1455. 14640   ! ******************************************************** !
  1456. 14650   !   Subroutine AWRITE to do full screen handling ***** !
  1457. 14660   ! TO SIMULATE THE CALL Awrite UTILITY OF THE HP86/HP87
  1458. 14670   !
  1459. 14680   ! ******************************************************** !
  1460. 14690 Awrite:   SUB Awrite(INTEGER A,B,K$)
  1461. 14700   S$="&a"&VAL$(A)&"r"&VAL$(B)&"C"
  1462. 14710   PRINT USING "#,K";CHR$(27)&S$
  1463. 14720   PRINT K$
  1464. 14730   SUBEND
  1465. 14740   ! ****************************************************
  1466. 14750   !
  1467. 14760   !  SUBROUTINE BWRITE TO POSITION THE CURSOR.
  1468. 14770   !
  1469. 14780   ! ****************************************************
  1470. 14790 Bwrite:  SUB Bwrite(INTEGER A,B)
  1471. 14800   S$="&a"&VAL$(A)&"r"&VAL$(B)&"C"
  1472. 14810   PRINT USING "#,K";CHR$(27)&S$
  1473. 14820   SUBEND
  1474. 14830 !
  1475. 14840 ! CALCULATE CHECK BYTE
  1476. 14850 ! --------------------
  1477. 14860 Cbyte:DEF FNCbyte$(S$)
  1478. 14870 INTEGER Tt1
  1479. 14880 Tt=0
  1480. 14890 Ll=LEN(S$)
  1481. 14900 FOR Ii=1 TO Ll
  1482. 14910 Tt=Tt+NUM(S$[Ii,Ii])
  1483. 14920 NEXT Ii ! sum S$
  1484. 14930 Tt1=BINAND(Tt+BINAND(Tt,192)/64,63)     ! Fold bits 7 & 8
  1485. 14940 Tt1$=FNChar$(Tt1)
  1486. 14950 Char:DEF FNChar$(INTEGER Nn)=CHR$(Nn+32)    !  Character = no + 32
  1487. 14960 RETURN Tt1$
  1488. 14970 FNEND
  1489. 14980 !
  1490. 14990 Kb:DEF FNKb$(Kk)
  1491. 15000 Kb$=VAL$(INT(Kk/102.4)/10)&"k  "
  1492. 15010 RETURN Kb$
  1493. 15020 FNEND
  1494. 15030 Decode:SUB Decode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Left$,INTEGER Sig(*),Sigj,Line_no,Pp,Inf,Sig0)
  1495. 15040 INTEGER Span2
  1496. 15050 DIM Line$[256]
  1497. 15060 Lf=0
  1498. 15070 ON Line_no GOTO 15080,15140,15200,15250,15300,15350,15410
  1499. 15080 CALL Linefill(S$,Line$,Left$,Lf)
  1500. 15090 IF NOT Lf THEN 15440
  1501. 15100 Line_no=2
  1502. 15110 File$=Line$[1,Lf-1]
  1503. 15120 Line$=""
  1504. 15130 Lf=0
  1505. 15140 CALL Linefill(S$,Line$,Left$,Lf)
  1506. 15150 IF NOT Lf THEN 15440
  1507. 15160 Title$=Line$[1,Lf-1]
  1508. 15170 Line_no=3
  1509. 15180 Line$=""
  1510. 15190 Lf=0
  1511. 15200 CALL Linefill(S$,Line$,Left$,Lf)
  1512. 15210 IF NOT Lf THEN 15440
  1513. 15220 Line1$=Line$[1,Lf-1]
  1514. 15230 Line$=""
  1515. 15240 Line_no=4
  1516. 15250 CALL Linefill(S$,Line$,Left$,Lf)
  1517. 15260 IF NOT Lf THEN 15440
  1518. 15270 Line2$=Line$[1,Lf-1]
  1519. 15280 Line$=""
  1520. 15290 Line_no=5
  1521. 15300 CALL Linefill(S$,Line$,Left$,Lf)
  1522. 15310 IF NOT Lf THEN 15440
  1523. 15320 Line3$=Line$[1,Lf-1]
  1524. 15330 Line$=""
  1525. 15340 Line_no=6
  1526. 15350 CALL Infofill(S$,Info$(*),Inf,Left$)
  1527. 15360 IF Inf>=30 THEN
  1528. 15370 Line_no=7
  1529. 15380 GOTO 15410
  1530. 15390 END IF
  1531. 15400 GOTO 15440
  1532. 15410 Span=VAL(Info$(2))
  1533. 15420 Span2=INT(Span)
  1534. 15430 CALL Arrfill(S$,Sig(*),Sigj,Span2,Sig0,Left$)
  1535. 15440 SUBEND
  1536. 15450 Encode:SUB Encode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),INTEGER Sig(*),J,Line_no,Maxl,Span,Sig0)
  1537. 15460 INTEGER L,S
  1538. 15470 COM Cr$[1],Lf$[1],INTEGER Bias,Bias2,Bias3,Lb1,Ub1,Lb2,Ub2,A1,A2,A3,Asoff
  1539. 15480 S$=""
  1540. 15490 SELECT Line_no
  1541. 15500 CASE 1
  1542. 15510 S$[1,10]="1"&TRIM$(Dnumbr$)&File$
  1543. 15520 S$[11]=Title$&Cr$&Lf$
  1544. 15530 CASE 2
  1545. 15540 S$=Line1$[1,80]
  1546. 15550 IF S$="" THEN S$=" "
  1547. 15560 CASE 3
  1548. 15570 S$=Line2$[1,80]
  1549. 15580 IF S$="" THEN S$=" "
  1550. 15590 CASE 4
  1551. 15600 S$=Line3$[1,80]
  1552. 15610 IF S$="" THEN S$=" "
  1553. 15620 CASE 5
  1554. 15630 FOR I=1 TO 15
  1555. 15640 S$[8*I-7;8]=Info$(I)
  1556. 15650 NEXT I
  1557. 15660 CASE 6
  1558. 15670 FOR I=16 TO 30
  1559. 15680 S$[8*(I-15)-7;8]=Info$(I)
  1560. 15690 NEXT I
  1561. 15700 CASE 7
  1562. 15710 FOR I=31 TO 45
  1563. 15720 S$[8*(I-30)-7;8]=Info$(I)
  1564. 15730 NEXT I
  1565. 15740 CASE 8
  1566. 15750 FOR I=46 TO 50
  1567. 15760 S$[8*(I-45)-7;8]=Info$(I)
  1568. 15770 NEXT I
  1569. 15780 CASE ELSE
  1570. 15790 IF J>Span THEN 15980
  1571. 15800 S=Sig(J)-Sig0
  1572. 15810 Sig0=Sig(J)
  1573. 15820 IF (S<Lb1) OR (S>Ub1) THEN 15850
  1574. 15830 Cn$=CHR$(ABS(S)+Bias)
  1575. 15840 GOTO 15920
  1576. 15850 IF (S<Lb2) OR (S>Ub2) THEN 15880
  1577. 15860 Cn$=CHR$(ABS(S) DIV A2+Bias2)&CHR$(ABS(S) MOD A2+Bias)
  1578. 15870 GOTO 15920
  1579. 15880 T=ABS(S)
  1580. 15890 Cn$=CHR$(T DIV A3+Bias3)
  1581. 15900 T=T MOD A3
  1582. 15910 Cn$=Cn$&CHR$(T DIV A2+Bias)&CHR$(T MOD A2+Bias)
  1583. 15920 IF S<0 THEN Cn$[1,1]=CHR$(NUM(Cn$)+Asoff)
  1584. 15930 S$=S$&Cn$
  1585. 15940 J=J+1
  1586. 15950 L=LEN(S$)
  1587. 15960 IF L>=Maxl THEN 15980
  1588. 15970 GOTO 15790
  1589. 15980 END SELECT
  1590. 15990 Line_no=Line_no+1
  1591. 16000 SUBEND
  1592. 16010 Linefill:SUB Linefill(S$,Line$,Left$,P0)
  1593. 16020 DIM Reol$[2]
  1594. 16030 S$=TRIM$(Left$&S$)
  1595. 16040 Left$=""
  1596. 16050 Reol$=CHR$(13)&CHR$(10)
  1597. 16060 P0=POS(S$,Reol$)
  1598. 16070 L0=LEN(S$)
  1599. 16080 L=P0-1
  1600. 16090 IF P0 THEN
  1601. 16100 IF L0<>2 THEN 16130
  1602. 16110 Left$=""
  1603. 16120 GOTO 16190
  1604. 16130 Left$=S$[P0+2,L0]
  1605. 16140 Line$=Line$&S$[1,L]
  1606. 16150 T=LEN(Line$)
  1607. 16160 Line$=Line$&RPT$(" ",256-T)
  1608. 16170 ELSE
  1609. 16180 Left$=S$[1,L0]
  1610. 16190 END IF
  1611. 16200 S$=""
  1612. 16210 SUBEND
  1613. 16220 Infofill:SUB Infofill(S$,Info$(*),INTEGER I,Left$)
  1614. 16230 S$=Left$&S$
  1615. 16240 Cr$=CHR$(13)
  1616. 16250 Lf$=CHR$(10)
  1617. 16260 P=POS(S$,Cr$)
  1618. 16270 IF P=0 THEN 16300
  1619. 16280 S$[P]=S$[P+1]
  1620. 16290 GOTO 16260
  1621. 16300 P=POS(S$,Lf$)
  1622. 16310 IF P=0 THEN 16340
  1623. 16320 S$[P]=S$[P+1]
  1624. 16330 GOTO 16300
  1625. 16340 L=LEN(S$)
  1626. 16350 IF L<8 THEN 16450
  1627. 16360 I=I+1
  1628. 16370 IF I>30 THEN 16450
  1629. 16380 Info$(I)=S$[1,8]
  1630. 16390 IF L>8 THEN S$=S$[9]
  1631. 16400 IF L=8 THEN
  1632. 16410 S$=""
  1633. 16420 GOTO 16450
  1634. 16430 END IF
  1635. 16440 GOTO 16340
  1636. 16450 Left$=S$
  1637. 16460 S$=""
  1638. 16470 SUBEND
  1639. 16480 Arrfill:SUB Arrfill(S$,INTEGER Sig(*),J,Span,Sig0,Left$)
  1640. 16490   INTEGER Pt,P,L,C1,Nc,T,S
  1641. 16500 COM Cr$[1],Lf$[1],INTEGER Bias,Bias2,Bias3,Lb1,Ub1,Lb2,Ub2,A1,A2,A3,Asoff
  1642. 16510 S$=Left$&S$
  1643. 16520 Pt=POS(S$,Cr$)
  1644. 16530 IF Pt=0 THEN 16560
  1645. 16540 S$[Pt]=S$[Pt+1]
  1646. 16550 GOTO 16520
  1647. 16560 Pt=POS(S$,Lf$)
  1648. 16570 IF Pt=0 THEN 16600
  1649. 16580 S$[Pt]=S$[Pt+1]
  1650. 16590 GOTO 16560
  1651. 16600 P=0
  1652. 16610 L=LEN(S$)
  1653. 16620 IF L=0 THEN 16860
  1654. 16630 C1=NUM(S$[P+1])-Bias
  1655. 16640 Nc=C1 DIV A1+1
  1656. 16650 C1=C1 MOD A1
  1657. 16660 T=C1
  1658. 16670 IF C1>=Asoff THEN C1=C1-Asoff
  1659. 16680 IF L<Nc THEN 16860
  1660. 16690 SELECT Nc
  1661. 16700 CASE 1
  1662. 16710 S=C1
  1663. 16720 S$=S$[P+2]
  1664. 16730 CASE 2
  1665. 16740 S=A2*C1+NUM(S$[P+2])-Bias
  1666. 16750 S$=S$[P+3]
  1667. 16760 CASE 3
  1668. 16770 S=A3*C1+A2*(NUM(S$[P+2])-Bias)+NUM(S$[P+3])-Bias
  1669. 16780 S$=S$[P+4]
  1670. 16790 END SELECT
  1671. 16800 IF T<>C1 THEN S=-S
  1672. 16810 Sig(J)=S+Sig0
  1673. 16820 Sig0=Sig(J)
  1674. 16830 J=J+1
  1675. 16840 IF J>Span THEN 16860
  1676. 16850 GOTO 16610
  1677. 16860 Left$=S$
  1678. 16870 S$=""
  1679. 16880 SUBEND
  1680. 16890 Get_info:SUB Get_info(Fnumber,Auto,Ins$(*),INTEGER Medium(*),Hpfile(*))
  1681. 16891 DIM Comms2$[30],Cr$[1],Lf$[1],Fname$[10]
  1682. 16892 Cr$=CHR$(13)
  1683. 16893 Lf$=CHR$(10)
  1684. 16900 ON ERROR GOSUB Get_info_err
  1685. 16910 Auto=1
  1686. 16920 ASSIGN #3 TO "DECNUM:T"
  1687. 16930 IF NOT Auto THEN RETURN
  1688. 16940 READ #3;Fnumber$
  1689. 16950 Fnumber=VAL(Fnumber$)
  1690. 16960 ASSIGN * TO #3
  1691. 16970 ASSIGN #3 TO "DEC1:T"
  1692. 16980 FOR I=1 TO Fnumber
  1693. 16990 READ #3,I;Comms2$
  1694. 17000 P=POS(Comms2$,Cr$&Lf$)
  1695. 17010 IF P<=0 THEN Get_info_ret
  1696. 17020 Send$=Comms2$[1,P-1]
  1697. 17030 IF Send$="1" THEN Ins$(I)="RECEIVE"
  1698. 17031 IF Send$="2" THEN Ins$(I)="SEND"
  1699. 17032 Comms2$[P,P+1]="  "
  1700. 17033 P1=POS(Comms2$,Cr$&Lf$)
  1701. 17034 Fname$=Comms2$[P+2,P1-1]
  1702. 17035 Ins$(I)=Ins$(I)&" "&Fname$
  1703. 17036 Comms2$[P1,P1+1]="  "
  1704. 17037 P2=POS(Comms2$,Cr$&Lf$)
  1705. 17038 Medium$=Comms2$[P1+2,P2-1]
  1706. 17039 Medium(I)=VAL(Medium$)
  1707. 17040 Comms2$[P2,P2+1]="  "
  1708. 17041 P3=POS(Comms2$,Cr$&Lf$)
  1709. 17042 F1$=Comms2$[P2+2,P3-1]
  1710. 17043 Hpfile(I)=VAL(F1$)
  1711. 17044 NEXT I
  1712. 17045 OFF ERROR
  1713. 17046 ASSIGN * TO #3
  1714. 17047 Get_info_ret: SUBEXIT
  1715. 17048 Get_info_err: IF (ERRN=80) OR (ERRN=56) THEN
  1716. 17049 Auto=0
  1717. 17050 OFF ERROR
  1718. 17051 SUBEXIT
  1719. 17052 END IF
  1720. 17053 PRINT "UNEXPECTED ERROR IN LINE ";ERRL
  1721. 17054 PRINT "ERROR NUMBER ";ERRN
  1722. 17065 STOP
  1723. 17089 SUBEND
  1724. 17090 SUB Dummy2
  1725. 17100 SUBEND
  1726. 17110 Samfile:SUB Samfile(INTEGER Sig(*),Sig1(*),D,Info$(*),File$,Title$,Line1$,Line2$,Line3$,Tf$)
  1727. 17120 DIM Line4$[200],Line5$[200],Pline1$[200],Pline2$[200],Pline2a$[100]
  1728. 17130 DIM Pline2b$[100],Pline3$[100],Notes$[1500],Data$[1500],Dir$[1500]
  1729. 17140 DIM Cr$[1],Lf$[1],Di$[1500],Dir1$[320]
  1730. 17150 Cr$=CHR$(13)
  1731. 17160 Lf$=CHR$(10)
  1732. 17170 Bl$=CHR$(130)
  1733. 17180 Clr$=CHR$(128)
  1734. 17190 ON D GOSUB Fetch,Openfile
  1735. 17200 SUBEXIT
  1736. 17210 Info_array:  ! Sets up INFO(*) for DUMMY2 for Spectra
  1737. 17220 FIXED 2
  1738. 17230 Info$(1)=VAL$(Tp)
  1739. 17240 Info$(2)=VAL$(Rnge)
  1740. 17250 Info$(3)=VAL$(V1)
  1741. 17260 Info$(4)=VAL$(V2)
  1742. 17270 Info$(5)=VAL$(C1)
  1743. 17280 Info$(6)=VAL$(C2)
  1744. 17290 Info$(7)=VAL$(S)
  1745. 17300 Info$(8)=VAL$(Smo)
  1746. 17310 Info$(9)=VAL$(Ex)
  1747. 17320 Info$(10)=VAL$(Sw)
  1748. 17330 Info$(11)=VAL$(Tm)
  1749. 17340 Info$(12)=VAL$(F1)
  1750. 17350 Info$(13)=VAL$(D1)
  1751. 17360 Info$(14)=VAL$(Epass)
  1752. 17370 Info$(15)=VAL$(Ret)
  1753. 17380 Info$(16)=VAL$(Nor)
  1754. 17390 STANDARD
  1755. 17400 GOTO Fetch_dir_redim
  1756. 17410 Info_array1:   ! Sets up INFO(*) for linescans
  1757. 17420 FIXED 2
  1758. 17430 Info$(1)=VAL$(Tp)
  1759. 17440 Info$(2)=VAL$(Xmax)
  1760. 17450 Info$(3)=VAL$(Ymin)
  1761. 17460 Info$(4)=VAL$(Ymax)
  1762. 17470 Info$(5)=VAL$(Smo)
  1763. 17480 Info$(6)=VAL$(Ex)
  1764. 17490 Info$(7)=VAL$(Con)
  1765. 17500 Info$(8)=VAL$(Dt)
  1766. 17510 Info$(9)=VAL$(F1)
  1767. 17520 Info$(10)=VAL$(D1)
  1768. 17530 Info$(11)=VAL$(Epass)
  1769. 17540 Info$(12)=VAL$(Ret)
  1770. 17550 Info$(13)=VAL$(Nor)
  1771. 17560 Info$(14)=VAL$(Mag)
  1772. 17570 Info$(15)=VAL$(Dirn)
  1773. 17580 Info$(16)=VAL$(Ea)
  1774. 17590 Info$(17)=VAL$(Eb)
  1775. 17600 STANDARD
  1776. 17610 GOTO Fetch_dir_redim
  1777. 17620 Info_array2:   ! Sets up INFO(*) for Images
  1778. 17630 FIXED 2
  1779. 17640 Info$(1)=VAL$(Tp)
  1780. 17650 Info$(2)=VAL$(M*N)
  1781. 17660 Info$(3)=VAL$(M)
  1782. 17670 Info$(4)=VAL$(N)
  1783. 17680 Info$(5)=VAL$(Dt)
  1784. 17690 Info$(6)=VAL$(F1)
  1785. 17700 Info$(7)=VAL$(D1)
  1786. 17710 Info$(8)=VAL$(Epass)
  1787. 17720 Info$(9)=VAL$(Ret)
  1788. 17730 Info$(10)=VAL$(Nor)
  1789. 17740 Info$(11)=VAL$(Mag)
  1790. 17750 Info$(12)=VAL$(Ea)
  1791. 17760 IF Tp=6 THEN Info$(12)=VAL$(E)
  1792. 17770 Info$(13)=VAL$(Eb)
  1793. 17780 Info$(14)=VAL$(Hist)
  1794. 17790 Info$(15)=VAL$(Stepx)
  1795. 17800 Info$(16)=VAL$(Stepy)
  1796. 17810 Info$(17)=VAL$(Startx)
  1797. 17820 Info$(18)=VAL$(Starty)
  1798. 17830 Info$(19)=VAL$(Nsets)
  1799. 17840 Info$(20)=VAL$(No_subims)
  1800. 17850 STANDARD
  1801. 17860 GOTO Fetch_dir_redim
  1802. 17870 ! -------------------------------------------------------------------
  1803. 17880 Openfile:    ! Converts to SAM Format
  1804. 17890 PRINT PAGE
  1805. 17900 PRINT TAB(20),"FILING DATA IN SAM FORMAT",LIN(1)
  1806. 17910 PRINT TAB(19),"ANSWER ANY QUESTIONS Y OR N.",LIN(2)
  1807. 17920 Send=0
  1808. 17930 Title$=TRIM$(Title$)&Cr$&Lf$
  1809. 17940 Line1$=TRIM$(Line1$)&Cr$&Lf$
  1810. 17950 Line2$=TRIM$(Line2$)&Cr$&Lf$
  1811. 17960 Line3$=TRIM$(Line3$)&Cr$&Lf$
  1812. 17970 PRINT TAB(10),"FILE RECEIVED IS: ",LIN(1)
  1813. 17980 PRINT Title$;Line1$;Line2$;Line3$,LIN(5)
  1814. 17990 ! Now convert data in Info$(*) to SAM Format
  1815. 18000 FOR I=1 TO 29
  1816. 18010 IF Info$(I)="" THEN 18040
  1817. 18020 Info(I)=VAL(Info$(I))
  1818. 18030 NEXT I
  1819. 18040 Tp=INT(Info(1))
  1820. 18050 IF Tp=1 THEN Spectrum
  1821. 18060 IF Tp=2 THEN Line_scan
  1822. 18070 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) THEN Image
  1823. 18080 PRINT TAB(10),Title$
  1824. 18090 PRINT TAB(10),"File type not recognised"
  1825. 18100 Message$="File type not recognised"
  1826. 18110 GOSUB Message
  1827. 18120 GOSUB Kjob
  1828. 18130 !
  1829. 18140 Gosub_store: GOSUB Store
  1830. 18150 PRINT "CONTROL PASSED BACK TO DEC PROGRAMME. "
  1831. 18160 PRINT "ANSWER QUESTIONS YES OR NO UNTIL TOLD OTHERWISE"
  1832. 18170 RETURN
  1833. 18180 ! --------------------------------------------------------------
  1834. 18190 ! Make up data for spectrum
  1835. 18200 Spectrum: !
  1836. 18210 Tp=INT(Info(1))
  1837. 18220 Rnge=INT(Info(2))
  1838. 18230 V1=INT(Info(3))
  1839. 18240 V2=INT(Info(4))
  1840. 18250 C1=INT(Info(5))
  1841. 18260 C2=INT(Info(6))
  1842. 18270 S=Info(7)
  1843. 18280 Smo=INT(Info(8))
  1844. 18290 Ex=INT(Info(9))
  1845. 18300 Sw=INT(Info(10))
  1846. 18310 Tm=INT(Info(11))
  1847. 18320 F1=INT(Info(12))
  1848. 18330 D1=INT(Info(13))
  1849. 18340 Epass=INT(Info(14))
  1850. 18350 Ret=INT(Info(15))
  1851. 18360 Nor=INT(Info(16))
  1852. 18370 Iturn=INT(Info(27))
  1853. 18380 Inum=INT(Info(28))
  1854. 18390 J0=INT(Info(29))
  1855. 18400 GOTO Gosub_store
  1856. 18410 ! --------------------------------------------------------------
  1857. 18420 Line_scan:! Makes up data for linescan
  1858. 18430 Tp=INT(Info(1))
  1859. 18440 Xmax=INT(Info(2))
  1860. 18450 Ymin=INT(Info(3))
  1861. 18460 Ymax=INT(Info(4))
  1862. 18470 Smo=INT(Info(5))
  1863. 18480 Ex=INT(Info(6))
  1864. 18490 Con=INT(Info(7))
  1865. 18500 Dt=INT(Info(8))
  1866. 18510 F1=INT(Info(9))
  1867. 18520 D1=INT(Info(10))
  1868. 18530 Epass=INT(Info(11))
  1869. 18540 Ret=INT(Info(12))
  1870. 18550 Nor=INT(Info(13))
  1871. 18560 Mag=INT(Info(14))
  1872. 18570 Dirn=INT(Info(15))
  1873. 18580 Ea=INT(Info(16))
  1874. 18590 Eb=INT(Info(17))
  1875. 18600 GOTO Gosub_store
  1876. 18610 !  ------------------------------------------------------------------
  1877. 18620 Image:  ! Makes up data for image
  1878. 18630 Tp=INT(Info(1))
  1879. 18640 M=INT(Info(3))
  1880. 18650 N=INT(Info(4))
  1881. 18660 Dt=INT(Info(5))
  1882. 18670 F1=INT(Info(6))
  1883. 18680 D1=INT(Info(7))
  1884. 18690 Epass=INT(Info(8))
  1885. 18700 Ret=INT(Info(9))
  1886. 18710 Nor=INT(Info(10))
  1887. 18720 Mag=INT(Info(11))
  1888. 18730 Ea=INT(Info(12))
  1889. 18740 Eb=INT(Info(13))
  1890. 18750 Hist=INT(Info(14))
  1891. 18760 Stepx=INT(Info(15))
  1892. 18770 Stepy=INT(Info(16))
  1893. 18780 Startx=INT(Info(17))
  1894. 18790 Starty=INT(Info(18))
  1895. 18800 Nsets=INT(Info(19))
  1896. 18810 No_subims=INT(Info(20))
  1897. 18820 GOTO Gosub_store
  1898. 18830 ! -----------------------------------------------------------------
  1899. 18840 P_spectrum:! Sets up Dir$ for spectrum
  1900. 18850 Pline1$="10  Fl: READ Tp,Rnge,V1,V2,C1,C2,S,Smo,Ex,Sw,Tm,F1,D1,Epass,Ret,Nor"
  1901. 18860 Pline2a$="20  DATA 1,"&VAL$(Rnge)&","&VAL$(V1)&","&VAL$(V2)&","&VAL$(C1)&","&VAL$(C2)&","&VAL$(S)&","&VAL$(Smo)&","&VAL$(Ex)&","&VAL$(Sw)&","
  1902. 18870 Pline2b$=VAL$(Tm)&","&VAL$(F1)&","&VAL$(D1)&","&VAL$(Epass)&","&VAL$(Ret)&","&VAL$(Nor)
  1903. 18880 Pline2$=Pline2a$&Pline2b$
  1904. 18890 Pline3$="30  RETURN"
  1905. 18900 Data$=TRIM$(Pline1$&Pline2a$&Pline2b$&Pline3$)
  1906. 18910 Name$="SPECTRUM__"
  1907. 18920 GOTO Gosub_concat
  1908. 18930 ! -----------------------------------------------------------------
  1909. 18940 P_linescan:! Sets up Dir$ for linescans
  1910. 18950 Pline1$="10  Fl: READ Tp,Xmax,Ymin,Ymax,Smo,Ex,Con,Dt,F1,D1,Epass,Ret,Nor,Mag,Dirn,Ea,Eb"
  1911. 18960 Pline2a$="20  DATA 2,"&VAL$(Xmax)&","&VAL$(Ymin)&","&VAL$(Ymax)&","&VAL$(Smo)&","&VAL$(Ex)&","&VAL$(Con)&","&VAL$(Dt)&","&VAL$(F1)&","
  1912. 18970 Pline2b$=VAL$(D1)&","&VAL$(Epass)&","&VAL$(Ret)&","&VAL$(Nor)&","&VAL$(Mag)&","&VAL$(Dirn)&","&VAL$(Ea)&","&VAL$(Eb)
  1913. 18980 Pline2$=Pline2a$&Pline2b$
  1914. 18990 Pline3$="30  RETURN"
  1915. 19000 Data$=TRIM$(Pline1$&Pline2a$&Pline2b$&Pline3$)
  1916. 19010 Name$="LSCAN_____"
  1917. 19020 GOTO Gosub_concat
  1918. 19030 ! ----------------------------------------------------------------
  1919. 19040 P_image:! Sets up Dir$ for images
  1920. 19050 Pline1$="10  Fl: READ Tp,M,N,Dt,F1,D1,Epass,Ret,Nor,Mag,Ea,Eb,Hist,Stepx,Stepy,Startx,Starty,Nsets,No_subims"
  1921. 19060 Pline2a$="20  DATA "&VAL$(Tp)&","&VAL$(M)&","&VAL$(N)&","&VAL$(Dt)&","&VAL$(F1)&","&VAL$(D1)&","&VAL$(Epass)&","&VAL$(Ret)&","&VAL$(Nor)&","&VAL$(Mag)
  1922. 19070 Pline2b$=","&VAL$(Ea)&","&VAL$(Eb)&","&VAL$(Hist)&","&VAL$(Stepx)&","&VAL$(Stepy)&","&VAL$(Startx)&","&VAL$(Starty)&","&VAL$(Nsets)
  1923. 19080 Pline2$=Pline2a$&Pline2b$
  1924. 19090 Pline3$=","&VAL$(No_subims)&"30  RETURN"
  1925. 19100 Data$=TRIM$(Pline1$&Pline2a$&Pline2b$&Pline3$)
  1926. 19110 Name$="IMAGE_____"
  1927. 19120 GOTO Gosub_concat
  1928. 19130 ! -----------------------------------------------------------------
  1929. 19140 Error_trap:  !
  1930. 19150 BEEP
  1931. 19160 IF ERRN=20 THEN GOTO 19250
  1932. 19170 IF ERRN=64 THEN Full=1
  1933. 19180 IF ERRN=64 THEN GOTO 19250
  1934. 19190 IF ERRN=32 THEN Message$="PROBABLY ATTEMPTING TO SEND DECODED FILE-"&Fname$
  1935. 19200 IF ERRN=32 THEN GOSUB Message
  1936. 19210 OFF ERROR
  1937. 19220 Message$=ERRM$
  1938. 19230 GOSUB Message
  1939. 19240 GOSUB Kjob
  1940. 19250 RETURN
  1941. 19260 ! -----------------------------------------------------------------
  1942. 19270 S_print:PRINTER IS 0
  1943. 19280 PRINT "DEC file "&Fname$&" stored on HP disc as file "&Dfile$
  1944. 19290 S_print2:PRINT USING "K";Line1$
  1945. 19300 PRINT USING "K";Line2$
  1946. 19310 PRINT USING "K";Line3$
  1947. 19320 PRINTER IS 16
  1948. 19330 RETURN
  1949. 19340 F_print:PRINTER IS 0
  1950. 19350 PRINT "HP file ";F1;" stored on DEC as file "&Fname$
  1951. 19360 GOTO S_print2
  1952. 19370 ! --------------------------------------------------------------
  1953. 19380 Name:IF Tp=1 THEN Name$="SPECTRA___"
  1954. 19390 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) OR (Tp=11) THEN Name$="IMAGE_____"
  1955. 19400 IF Tp=2 THEN Name$="LSCAN_____"
  1956. 19410 IF Tp=5 THEN Name$="HISTOGRAM_"
  1957. 19420 RETURN
  1958. 19430 !
  1959. 19440 Fetch:! ---------------------------------------------------------------
  1960. 19450 Fetched=1
  1961. 19460 Line1$=""
  1962. 19470 Line2$=""
  1963. 19480 Line3$=""
  1964. 19490 GOSUB Find_file
  1965. 19500 ON Medium GOSUB Fetch_disc1,Fetch_tape1
  1966. 19510 IF Fetch_check=1 THEN GOTO Fetch_return
  1967. 19520 GOSUB Fetch_direct
  1968. 19530 IF Fetch_check=1 THEN GOTO Fetch_return
  1969. 19540 IF Medium=2 THEN GOSUB Fetch_tape2
  1970. 19550 Fetch_return:RETURN
  1971. 19560 !
  1972. 19570 Fetch_tape1:! ---------------------------------------------------------
  1973. 19580 Fetch_check=0
  1974. 19590 PRINT "CHANGE TAPES NOW, PRESS CONT TO GO ON"
  1975. 19600 PAUSE
  1976. 19610 MASS STORAGE IS ":T15"
  1977. 19620 ASSIGN #3 TO "DIR:T15"
  1978. 19630 ASSIGN #5 TO "Dnumbr:T15"
  1979. 19640 READ #5;Dnumbr$
  1980. 19650 D1=VAL(Dnumbr$)
  1981. 19660 READ #3,F1;Dir$
  1982. 19670 IF Dir$[2,3]="00" THEN GOSUB No_file
  1983. 19680 Dim=LEN(Dir$)
  1984. 19690 IF Dim=320 THEN Dir$=Dir$&RPT$(" ",1180)
  1985. 19700 Fetch_tape1_ret:RETURN
  1986. 19710 !
  1987. 19720 Fetch_disc1: ! --------------------------------------------------------
  1988. 19730 Fetch_check=0
  1989. 19740 D1=0
  1990. 19750 MASS STORAGE IS ":Q7"
  1991. 19760 ON ERROR GOSUB No_file_hp
  1992. 19770 FREAD "G"&VAL$(F1),Sig1(*)
  1993. 19780 OFF ERROR
  1994. 19790 IF Fetch_check=1 THEN GOTO Fetch_disc1_ret
  1995. 19800 Size1=ROW(Sig1)
  1996. 19810 Size=Sig1(Size1)
  1997. 19820 REDIM Sig(1:Size)
  1998. 19830 MAT Sig=Sig1
  1999. 19840 L=Size1-Size-1
  2000. 19850 ENTER Sig1(Size+1) USING "#,"&VAL$(2*L)&"A";Dir$
  2001. 19860 Fetch_disc1_ret:RETURN
  2002. 19870 !
  2003. 19880 No_file_hp: Ee=ERRN
  2004. 19890 Ll=ERRL
  2005. 19900 OFF ERROR
  2006. 19910 IF (Ee=56) AND (Ll=19770) THEN
  2007. 19920 DISP "No such HP file"
  2008. 19930 ELSE
  2009. 19940 PRINT "UNEXPECTED ERROR"
  2010. 19950 PRINT USING "6A,K,9A,K";"ERROR";Ee;"AT LINE ";Ll
  2011. 19960 END IF
  2012. 19970 Fetch_check=1
  2013. 19980 RETURN
  2014. 19990 Find_file:! ---------------------------------------------------
  2015. 20000 Col=POS(Tf$,":")
  2016. 20010 IF Col=0 THEN
  2017. 20020 Tf$=Tf$&":Q"
  2018. 20030 GOTO 20000
  2019. 20040 END IF
  2020. 20050 MASS STORAGE IS Tf$[Col]
  2021. 20060 IF Tf$[Col+1;1]="Q" THEN Medium=1
  2022. 20070 IF Tf$[Col+1;1]="T" THEN Medium=2
  2023. 20080 F1=VAL(Tf$[2,Col-1])
  2024. 20090 RETURN
  2025. 20100 Fetch_direct:! ---------------------------------------------------
  2026. 20110 Fetch_check=0
  2027. 20120 ASSIGN #4 TO "DUMMY1:Q7"
  2028. 20130 P2=POS(Dir$," ")
  2029. 20140 File$=Dir$[1,P2-1]
  2030. 20150 Dir$=TRIM$(Dir$)
  2031. 20160 P1=POS(Dir$,Cr$&Lf$)
  2032. 20170 Name$=Dir$[P2+1,P2+10]
  2033. 20180 Di$=Dir$[POS(Dir$,Cr$&Lf$)+2]
  2034. 20190 R1=POS(Di$,Cr$&Lf$)
  2035. 20200 Fetch_big:Line1$=Di$[1,R1-1]
  2036. 20210 Di$[R1,R1+1]="  "
  2037. 20220 R2=POS(Di$,Cr$&Lf$)
  2038. 20230 Line2$=Di$[R1+2,R2-1]
  2039. 20240 Di$[R2,R2+1]="  "
  2040. 20250 R3=POS(Di$,Cr$&Lf$)
  2041. 20260 IF R3=0 THEN 20360
  2042. 20270 Line3$=Di$[R2+2,R3-1]
  2043. 20280 Di$[R3,R3+1]="  "
  2044. 20290 R4=POS(Di$,Cr$&Lf$)
  2045. 20300 IF R4=0 THEN 20360
  2046. 20310 Line4$=Di$[R3+2,R4-1]
  2047. 20320 R5=POS(Di$,Cr$&Lf$&"10  ")-1
  2048. 20330 IF R5<R4 THEN R5=R4+2
  2049. 20340 Line5$=Di$[R4+2,R5]
  2050. 20350 Di$=Dir$[POS(Dir$,Cr$&Lf$&"10  "),LEN(Dir$)]
  2051. 20360 FOR I=1 TO 5
  2052. 20370   P=POS(Di$,VAL$(I)&"0  ")
  2053. 20380   Lstart=P
  2054. 20390   IF P=0 THEN 20450
  2055. 20400   P=POS(Di$,VAL$(I+1)&"0  ")
  2056. 20410   Lend=P-1
  2057. 20420   IF P=0 THEN Lend=LEN(Di$)
  2058. 20430   PRINT #4,I;Di$[Lstart,Lend]
  2059. 20440 NEXT I
  2060. 20450 LINK "DUMMY1:Q",21370,Gosub_fl
  2061. 20460 Gosub_fl: GOSUB Fl
  2062. 20470 FOR I=1 TO 50
  2063. 20480 Info$(I)="0.00"
  2064. 20490 NEXT I
  2065. 20500 IF Tp=1 THEN Size=Rnge
  2066. 20510 IF Tp=2 THEN Size=Xmax
  2067. 20520 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) THEN Size=M*N
  2068. 20530 IF Tp=1 THEN Info_array
  2069. 20540 IF Tp=2 THEN Info_array1
  2070. 20550 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) THEN Info_array2
  2071. 20560 PRINT TAB(10),"File type not recognised"
  2072. 20570 Message$="File type not recognised"
  2073. 20580 GOSUB Message
  2074. 20590 GOSUB Kjob
  2075. 20600 Fetch_dir_redim: REDIM Sig1(1:Size),Sig(1:Size)
  2076. 20610 Fetch_dir_ret:RETURN
  2077. 20620 !
  2078. 20630 Fetch_tape2:! ---------------------------------------------------------
  2079. 20640 MASS STORAGE IS ":T15"
  2080. 20650 ASSIGN #2 TO File$
  2081. 20660 BUFFER #2
  2082. 20670 READ #2;Sig(*)
  2083. 20680 ASSIGN * TO #2
  2084. 20690 MASS STORAGE IS ":Q7"
  2085. 20700 REWIND ":T15"
  2086. 20710 Fetch_tape2_ret:RETURN
  2087. 20720 !
  2088. 20730 Store:! ---------------------------------------------------------------
  2089. 20740 IF Tp=1 THEN Size=Rnge
  2090. 20750 IF Tp=2 THEN Size=Xmax
  2091. 20760 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) THEN Size=M*N
  2092. 20770 EXIT GRAPHICS
  2093. 20780 GOSUB Store_disc
  2094. 20790 Wh=1
  2095. 20800 PRINT "Data stored as file ";Dfile$
  2096. 20810 GOSUB S_print
  2097. 20820 Store_ret:RETURN
  2098. 20830 !  --------------------------------------------------------------
  2099. 20840 Concat:Notes$=TRIM$(Line1$&Line2$&Line3$&Line4$&Line5$)
  2100. 20850 Dir$=RPT$(" ",7)&Name$&Cr$&Lf$&Notes$&Data$
  2101. 20860 L=LEN(Dir$)
  2102. 20870 Dir_ok:Dir$=TRIM$(Dir$)
  2103. 20880 Concat_ret:RETURN
  2104. 20890 !
  2105. 20900 Store_disc: ! --------------------------------------------------------
  2106. 20910 REDIM Sig1(1:Size)
  2107. 20920 MAT Sig1=Sig
  2108. 20930 Dz=0
  2109. 20940 GOSUB Slot_disc
  2110. 20950 Dim=1500
  2111. 20960 IF Tp=1 THEN P_spectrum
  2112. 20970 IF Tp=2 THEN P_linescan
  2113. 20980 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) OR (Tp=11) THEN P_image
  2114. 20990 Gosub_concat:  GOSUB Concat
  2115. 21000 GOSUB Entry_disc
  2116. 21010 GOSUB Redim2
  2117. 21020 OUTPUT Sig1(Size+1) USING "#,"&VAL$(2*Ldir)&"A,W";Dir$,Size
  2118. 21030 FCREATE Dfile$&":Q7",INT(Rnge2/128)+INT(Rnge2/32768)+3
  2119. 21040 LINK "GWRITE:Q7",21370,Store_disc_call
  2120. 21050 Store_disc_call:CALL Gwrite(Rnge2,Slot,Sig1(*))
  2121. 21060 GOSUB Update
  2122. 21070 Store_end:DISP
  2123. 21080 Store_return:RETURN
  2124. 21090 Update:! -----------------------------------------------------------------
  2125. 21100 ASSIGN #3 TO "GNUMBR:Q7"
  2126. 21110 PRINT #3;Slot
  2127. 21120 ASSIGN * TO #3
  2128. 21130 Update_return:RETURN
  2129. 21140 !
  2130. 21150 Slot_disc: ! ----------------------------------------------------------
  2131. 21160 ASSIGN #3 TO "GNUMBR:Q7"
  2132. 21170 READ #3;Gnumbr
  2133. 21180 ASSIGN * TO #3
  2134. 21190 Slot_disc_found:Slot=Gnumbr+1
  2135. 21200 Slot_disc_ret:RETURN
  2136. 21210 !
  2137. 21220 Entry_disc: ! ----------------------------------------------------------
  2138. 21230 Dfile$="G"&VAL$(Slot)
  2139. 21240 Di$=Dfile$&" "&Dir$
  2140. 21250 Dirlen=LEN(Di$)
  2141. 21260 Ldir=(Dirlen+1) DIV 2
  2142. 21270 Dir$=Di$&RPT$(" ",Ldir*2-Dirlen)
  2143. 21280 Entry_disc_ret:RETURN
  2144. 21290 !
  2145. 21300 Redim2:! ------------------------------------------------------------------
  2146. 21310 Rnge2=Size+Ldir+1
  2147. 21320 REDIM Sig(1:Size)
  2148. 21330 REDIM Sig1(1:Rnge2)
  2149. 21340 Redim2_end:RETURN
  2150. 21350 ! -----------------------------------------------------------------------
  2151. 21360 !
  2152. 21370 Fl:READ Tp,M,N,Dt,F1,D1,Epass,Ret,Nor,Mag,E,Stepx,Stepy,Startx,Starty,Nsets,No_subims
  2153. 21380 DATA 4,128,128,10,2916,0,50,0,0,500,0,4,4,1,1,2,1
  2154. 21390 RETURN
  2155.