10 ! **************************************************************** ! 20 ! **************** New Version for HP9845 Derived from *********** ! 30 ! * * ! 40 ! * KERMIT DATA TRANSFER PROGRAM FOR THE HP86 MICROCOMPUTER * ! 50 ! * * ! 60 ! * Version 1.00 : Date:- 14 Mar 86 at 16:30 * ! 70 ! * * ! 80 ! * Programmer:- Martin J. Rootes * ! 90 ! * Location :- Computer Services Department, * ! 100 ! * Sheffield City Polytechnic. * ! 110 ! * * ! 120 ! **************************************************************** ! 130 ! ******** Rob Fletcher , Chris Walker , University of York ****** ! 131 ! * 132 ! * LAST UPDATED 6 Nov 86 at 18:30 133 ! * 134 ! * This program is designed to send both ordinary data files and 135 ! * special files stored in BDAT format in a manner unique to the 136 ! * SAM system. It is also designed to send data in a remote manner 137 ! * by reading a control file to find which files to send. Hence 138 ! * the program does not require the presence of a user and with 139 ! * the aid of the 'AUTOSTART' bootstrap facility, the data may be 140 ! * sent in the middle of the night. 141 ! * In order to send ordinary data files, alter line 840 to 142 ! * Datatype=1 143 ! * This program is purely designed to send data to a mainframe 144 ! * computer. Many of the parameters in the 'SET' commands cannot 145 ! * be changed. For instance, the PARITY cannot be changed and the 146 ! * host Kermit must be set to PARITY EVEN. For further information 147 ! * see the Kermit manual for the HP86 Kermit upon which this program 148 ! * is based. 150 ! ************************************************************** ! 160 OPTION BASE 0 170 MASS STORAGE IS ":Q" 171 CCOM 4428 180 COM Cr$[1],Lf$[1],INTEGER Bias,Bias2,Bias3,Lb1,Ub1,Lb2,Ub2,A1,A2,A3,Asoff 190 INTEGER Sig(17519),Sig1(17159),Sigj,Line_no,Span,Inf,Sig0,Medium(80),Hpfile(80) 200 DIM Info$(50),Title$[256],Line1$[180],Line2$[200],Line3$[200],Left$[256] 210 DIM Ins$(80)[18] 220 DIM Ibuff$[264],Obuff$[264] ! Define input & output buffers 230 DIM K$[1],Kk$[1],I$[256],Line$[80] ! Define string variables 240 DIM Esc$[1],Bel$[1] ! Define control characters 250 DIM El$[1],Bs$[1],Del$[1],Null$[1] ! '' '' '' 260 DIM Sp$[1] ! Define space 270 DIM Resp$[1] 280 INTEGER S1,S2,S3,S4,K,R,C,I,F ! Define integer variables 290 PRINTER IS 16 300 Cr$[1]=CHR$(13) 310 Lf$=CHR$(10) ! & 320 Esc$[1]=CHR$(27) 330 Bel$=CHR$(7) ! Escape & bell 340 El$[1]=CHR$(154) 350 Bs$=CHR$(155) ! Endline & Backspace keys 360 Del$[1]=CHR$(127) 370 Null$=CHR$(0) ! Delete & Null 380 Brk$=CHR$(2) 390 Ebrk$=CHR$(28) 400 Sp$=" " ! Space 410 DIM Rp$[96],Op$[96],Id$[91],Od$[91] ! Packets 420 DIM S$[256],Db$[256],Sf$[17],Df$[40],T$[1],Rt$[1],Cc$[1] ! 430 DIM Si$[1],Sh$[1],Sd$[1],Se$[1],Sb$[1],Tm$[1],Ak$[1],Nk$[1] ! Packet types 440 DIM Rqctl$[1],Sqctl$[1],Rpadc$[1],Spadc$[1] ! Prefix & pad 450 DIM Mk$[1],Seol$[1],Reol$[1],Crlf$[4] ! Mark & EOLs 460 INTEGER N,S,T,Ee,Ff,Ii,Jj,Ll,Mm,Rr,Tt,Np ! Temp vars 470 INTEGER Nn,Rn,Db,Ttmo,Nk,Bp,Rrr,Rc,Sr,Ssc ! Parameters 480 INTEGER Rmaxl,Smaxl,Maxl,Minl,Rto,Sto,Rnpad,Snpad,Reol,Seol,Tmo,Stm,Rlim 490 Si$="S" 500 Sh$="F" 510 Sd$="D" 520 Se$="Z" 530 Sb$="B" ! Send packet types 540 Ak$="Y" 550 Nk$="N" 560 Tm$="T" 570 Er$="E" ! Other packet types 580 Mk$=CHR$(1) 590 Crlf$="#M#J" ! Mark ^A, 600 Seol$=Reol$=Cr$ 610 Rpadc$=Null$ 620 Sqctl$="#" ! EOL's, pad char & prefix 630 Rmaxl=94 640 Rto=Sto=20 650 Rnpad=0 660 Seol=13 ! Max len, Timeouts, pad & eol 670 Rlim=10 680 Stm=10000 690 Rrr=17 700 Sr=15 710 Rc=Ssc=10 ! Retries, send timeout 720 Db=1 ! Debug (ON FOR TESTING) 730 DIM F$[80],Cl$[61],Cp$[24] 740 Cl$="CONNECT, SEND, RECEIVE, SET, SHOW, EXIT, QUIT, CAT" 750 Kp$="KERMIT-HP9845" 760 Cp$=Kp$ ! Kermit prompt, Command prompt 770 DIM Vc$[63],Dt$[1],Cn$[1],Ul$[1],Ftyp$[8] ! Dimension variables 780 Vc$=".1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ" ! Legal characters 790 Dt$="." 800 Cn$=":" 810 Ul$="_" 820 Q$=CHR$(34) ! Dot, colon, underline & quote 830 Ftyp$="ENC" ! Default file type 831 ! Data type 1 is for the standard DATA file 832 ! Data type 2 is for the SAM BDAT files. 840 Data_type=2 850 Line_no=1 860 Sigj=1 870 Span=1 880 Bias=33 890 Bias2=Bias+27 900 Bias3=Bias+54 910 Lb1=-13 920 Ub1=12 930 Lb2=-1052 940 Ub2=971 950 A1=27 960 A2=81 970 A3=6561 980 Asoff=13 990 EXIT GRAPHICS 1000 ! PAGESIZE 24 1010 PRINT PAGE 1020 Rr=0! Set no of lines (24) 1030 DIM Em$(24)[24]! 1040 Em$(0)="Transfer successful" 1050 Em$(1)="Timeout receiving" 1060 Em$(2)="NAK received" 1070 Em$(3)="Checksum error" 1080 Em$(4)="Incorrect packet" 1090 Em$(5)="Timeout sending" 1100 Em$(6)="Cannot rename file" 1110 Em$(7)="Disc write protected" 1120 Em$(8)="**File closed*" 1130 Em$(9)="File does not exist" 1140 Em$(10)="Incorrect file type" 1150 Em$(11)="*Random overflow*" 1160 Em$(12)="Read error" 1170 Em$(13)="End of file" 1180 Em$(14)="Record does not exist" 1190 Em$(15)="No M.S. device" 1200 Em$(16)="Directory full" 1210 Em$(17)="Volume not found" 1220 Em$(18)="MSUS not found" 1230 Em$(19)="Read verify error" 1240 Em$(20)="Disc full" 1250 Em$(21)="Medium damaged" 1260 Em$(22)="Disc drive fault" 1270 Em$(23)="Data type error" 1280 Em$(24)="Transfer aborted" 1290 Fse$=CHR$(60) 1300 FOR Ii=66 TO 72 1310 Fse$=Fse$&CHR$(Ii) 1320 NEXT Ii 1330 Fse$=Fse$&CHR$(120) 1340 FOR Ii=124 TO 130 1350 Fse$=Fse$&CHR$(Ii) 1360 NEXT Ii 1370 DIM A$(9)[18],St$(1)[9],Sst$(1)[8] 1380 A$(0)="initialise " 1390 A$(1)="file header " 1400 A$(2)="data " 1410 A$(3)="end of file " 1420 A$(4)="break " 1430 A$(5)="error " 1440 A$(6)="ACK " 1450 A$(7)="NAK " 1460 A$(8)="file header/break " 1470 A$(9)="data/EOF " 1480 St$(0)="Sending" 1490 Sst$(0)="sent" 1500 St$(1)="Receiving" 1510 Sst$(1)="received" 1520 DIM Re$[4],Pf$[18]! End of record sequence, previous file name 1530 INTEGER Re,Rl,Nr! No of chars in Re$, Record length, No of records 1540 Re$=Cr$&Lf$ 1550 Re=LEN(Re$) 1560 Rl=256 1570 Nr=40 1580 Fs=Rl*Nr/1024 1590 Pf$=" " 1600 DIM Sl$[164],Oo$[7],Dx$[10],Fc$[23],Pt$[28],Br$[8],Hs$[29] 1610 Sl$="TIMEOUT, RETRIES, SEND-CONVERT, DEBUG, PREFIX, END-OF-LINE, " 1620 Sl$=Sl$&"RECORD-END, FILE-SIZE, RECORD-LENGTH, NO-OF-RECORDS, " 1630 Sl$=Sl$&"DUPLEX, LOCAL-ECHO, FLOW-CONTROL, HANDSHAKE, PARITY" 1640 Oo$="OFF, ON" 1650 Dx$="FULL, HALF" 1660 Fc$="NONE, XON/XOFF, DTR/RTS" 1670 Pt$="NONE, ODD, EVEN, MARK, SPACE" 1680 Br$="110, 300" 1690 Hs$="NONE, BELL, LF, CR, XON, XOFF" 1700 DIM Ss$[47],Rs$[32] 1710 Ss$="SEND "&Q$&"Source filename"&Q$&" <"&Q$&"Destination filespec"&Q$&">" 1720 Rs$="RECEIVE <"&Q$&"Destination filespec"&Q$&">" 1730 DIM Io$[14],Ic$[14],Iv$[13] 1740 Io$="Illegal option" 1750 Ic$="Illegal string" 1760 Iv$="Illegal value" 1770 INTEGER Br,Dx,Le,Fc,Hs,Pt,Sc,Ps,Pp,Nf,Ft 1780 Br=Dx=Le=1 1790 Pt=3 1800 Fc=Sc=Ps=0 1810 Hs=4 1820 GOSUB Rs_set 1830 CALL Get_info(Fnumber,Auto,Ins$(*),Medium(*),Hpfile(*)) 1840 IF Auto THEN 1850 GOSUB Connect 1860 GOSUB Login 1870 GOSUB R_kermit 1880 FOR Af=1 TO Fnumber 1900 IF Ins$(Af)[1,1]="R" THEN 1901 CWRITE 2;"RECEIVE",ENDLINE 1902 GOSUB Exit1 1910 S$=CHR$(34)&"G"&VAL$(Hpfile(Af))&CHR$(34) 1920 GOSUB Send_file 1930 GOTO 1990 1940 END IF 1950 IF Ins$(Af)[1,1]="S" THEN 1951 CWRITE 2;Ins$(Af),ENDLINE 1952 GOSUB Exit1 1960 GOSUB Rec_file 1970 GOTO 1990 1980 END IF 1990 NEXT Af 1991 GOSUB End_job 2000 END IF 2010 ! ******************************************************************** ! 2020 ! * * ! 2030 ! * COMMAND PROCESSOR SECTION * ! 2040 ! * * ! 2050 ! ******************************************************************** ! 2060 ! # 2070 ! # This section passes a parameter list to the required command in S$ 2080 ! 2090 ! COMMAND PROCESSOR 2100 ! ----------------- 2110 Com_proc:GOSUB Dkeys ! Set keys to jump to dummy routine 2120 CALL Bwrite(20,0) 2130 PRINT Cp$&" > Enter command ";! Display command prompt 2140 RESUME INTERACTIVE! Resort to normal keyboard operation 2150 LINPUT S$ 2160 Cp$=Kp$! Input string, reset command prompt 2170 SUSPEND INTERACTIVE ! Block out keyboard again 2180 CALL Awrite(19,0,RPT$(" ",80)) ! Blank any message from previous command 2190 CALL Awrite(22,0,RPT$(" ",160)) ! '' '' '' '' '' '' 2200 GOSUB Split ! Split at first space 2210 C=FNInlist(F$,Cl$,Sp$)! Is command in command list 2220 IF C=0 THEN CALL Awrite(22,0,"Invalid command - "&F$) ! No - display 2230 IF C<1 THEN 2120! ? - re-enter 2240 ON C GOSUB Connect,Send_file,Rec_file,Set,Show_pars,Exit,Exit,Dir 2250 GOTO Com_proc 2260 ! 2270 ! ROUTINE TO SPLIT STRING AT FIRST SPACE OR QUOTE 2280 ! ----------------------------------------------- 2290 Split:S$=TRIM$(S$) ! Trim leading/trailing spaces 2300 Pp=POS(S$,Q$) 2310 P=POS(S$,Sp$) ! Find position of qoute & space 2320 IF Pp*P=0 THEN 2330 IF Pp>P THEN P=Pp 2340 ELSE 2350 IF Pp

0 THEN 2610 CALL Awrite(19,0,Em$(Ff)) 2620 RETURN ! If error display message 2630 END IF 2640 FOR I=1 TO 4 2650 PRINT 2660 NEXT I 2670 RETURN ! Move screen up 4 lines 3050 ! 3060 Login: CWRITE 2;ENDLINE 3070 CWRITE 2;"CALL VAXA",ENDLINE 3071 CWRITE 2;"PHYS2",ENDLINE 3080 Pass$="BAGDIN" 3090 CWRITE 2;Pass$,ENDLINE 3100 RETURN 3110 ! 3120 R_kermit: CWRITE 2;"KERMIT",ENDLINE 3130 CWRITE 2;"SET PARITY EVEN",ENDLINE 3131 RETURN 3132 End_job: CWRITE 2;"Q",ENDLINE 3133 CWRITE 2;"LOGOUT",ENDLINE 3134 GOTO Exit 3159 ! ****************************************************************** ! 3160 ! * * ! 3170 ! * TERMINAL EMULATION * ! 3180 ! * * ! 3190 ! ****************************************************************** ! 3200 Connect: F=Ff=0 ! Reset escape flag & cr flag 3210 C=0 3220 CALL Bwrite(0,0) 3230 PRINT PAGE ! Clear screen 3240 PRINT "HP98 Kermit - Terminal emulation mode" 3250 PRINT 3260 PRINT "Function key Escape character Action" 3270 PRINT "--------------------------------------------------" 3280 PRINT " k1 C RETURN to KERMIT" 3290 PRINT " k7 B Transmit break" 3300 PRINT " k14 Enable transmit" 3310 PRINT " REMEMBER TO 'SET PARITY EVEN' ON HOST COMPUTER" 3320 CALL Bwrite(20,0) ! Move cursor to first position 3330 Del=5 ! Keyboard delay = 05 milliseconds 3340 ON KBD 3 GOSUB Outkey 3350 CCONTROL 2;XON 3360 ON INT #3,2 GOSUB Receive 3370 ON INT #2,1 GOSUB Transmit 3380 Kk$=" " 3390 IF Auto THEN RETURN 3400 ! 3410 ! START OF LOOP 3420 ! ------------- 3430 Eactive=1 3440 Spin: IF Eactive THEN Spin 3450 OFF INT #3 3460 OFF INT #2 3470 RETURN 3480 Transmit: IF NOT CSTAT(2,2) THEN RETURN 3490 CREAD 2;A$ 3500 PRINT A$; 3510 RETURN 3520 Receive: IF NOT CSTAT(2,1) THEN RETURN 3530 CREAD 2;A$ 3540 PRINT A$; 3550 IF CSTAT(2,3) THEN PRINT 3560 GOTO Receive 3570 Outkey: Line$=KBD$ 3580 IF POS(Line$,Brk$) THEN Break 3590 IF NOT Eactive THEN RETURN 3600 IF POS(Line$,Ebrk$) THEN 3690 3610 IF NUM(Line$)<255 THEN 3670 3620 IF NUM(Line$[2;1])=1 THEN Exit1 3630 IF NUM(Line$[2;1])=7 THEN GOSUB Break 3640 IF NUM(Line$[2;1])=14 THEN GOSUB Tx_en 3650 CWRITE 2;ENDLINE 3660 RETURN 3670 CWRITE 2;Line$ 3680 RETURN 3690 Eactive=0 3700 RETURN 3710 Force_exit: CCONTROL 2;SUSPEND 3720 PRINT "ABORT ON FATAL ERROR" 3730 RETURN 3740 ! 3750 ! EXIT ROUTINE 3760 ! ------------ 3770 Exit1: ! END ALL INPUT/OUTPUT 3780 RESUME INTERACTIVE 3790 OFF INT #2 3800 OFF INT #3 3810 PRINT PAGE ! Reset 3820 Eactive=0 3830 RETURN ! RETURN 3840 ! 3850 ! TRANSMIT A BREAK 3860 ! -------------------- 3870 Break:! REQUEST 2;8 3880 CCONTROL 2;SUSPEND 3890 PRINT LIN(1),"**** BREAK ****" 3900 RETURN ! Transmit break signal 3910 ! 3920 ! RE-ENABLE TRANSMITER 3930 ! -------------------- 3940 Tx_en: CCONTROL 2;XON ! RESUME 10 @@@@ 3950 ON INT #3,2 GOSUB Receive 3960 ON INT #2,1 GOSUB Transmit 3970 RETURN ! Re-enable transmiter 3980 ! ***************************************************************** ! 3990 ! * * ! 4000 ! * SEND FILE - EXTRACT FILE NAME SECTION * ! 4010 ! * * ! 4020 ! ***************************************************************** ! 4030 ! # This section extracts the file names from the parameter list following 4040 ! # the SEND command . 4050 ! # S$ - contains the parameter list 4060 ! # 4070 ! 4080 ! EXTRACT FILE NAMES FROM PARAMETER LIST 4090 ! -------------------------------------- 4100 Send_file: S$=TRIM$(S$) 4110 CCONTROL 2;READALL ON 4120 Line_no=1 4130 Sigj=1 4140 Span=2 4150 Sig0=0 4160 Df$="" ! Strip excess blanks from parameters 4170 IF S$="?" THEN 4180 CALL Awrite(22,0,Ss$) 4190 RETURN ! Display send syntax 4200 END IF 4210 Pp=FNFsplit(S$,Q$,Ll) 4220 IF Pp=0 THEN Errfn ! Check for "filename" 4230 Sf$=TRIM$(S$[2,Pp]) ! Get source filename 4240 IF Ll0 THEN S$=S$[1,Pp-1] ! Extract file name 4370 ! 4380 ! CHECK FILE NAME AND CONVERT TO A 'LEGAL' NAME 4390 ! --------------------------------------------- 4400 Chckfn: Ll=LEN(S$) 4410 Ff=0 4420 Jj=0 ! Get len,clear flag,reset char count 4430 S$=UPC$(S$) ! Convert to upper case 4440 IF POS(S$,Dt$) THEN 4500 ! If name contains "." skip 4450 Pp=POS(S$,Sp$) 4460 IF Pp>0 THEN 4490 ! If name contains space convert to "." 4470 Pp=POS(S$,Ul$) 4480 IF Pp=0 THEN 4500 ! If name does not contain "_" skip 4490 S$[Pp,Pp]=Dt$ ! Convert character to "." 4500 FOR Ii=1 TO Ll 4510 Pp=POS(Vc$,S$[Ii,Ii]) ! Check char with legal list 4520 IF (Pp=0) OR (Pp=1) AND ((Ff=1) OR (Jj=0) OR (Jj=Ll-1)) THEN 4560! skip if illegal 4530 IF Pp=1 THEN Ff=1 ! Set flag to ensure only one "." 4540 Jj=Jj+1 4550 Df$[Jj,Jj]=S$[Ii,Ii] ! Transfer legal character to file name 4560 NEXT Ii 4570 IF Jj=0 THEN 4580 Df$=Sf$ 4590 GOTO 4880 ! If file name illegal send source name 4600 END IF 4610 Ll=LEN(Df$) 4620 Pp=POS(Df$,Dt$) ! Find length of name and "." position 4630 IF Pp=0 THEN 4640 Df$=Df$&"." 4650 Pp=Ll ! If no "." add one to end of Df$ 4660 END IF 4670 IF Pp=Ll THEN Df$=Df$&Ftyp$ ! If "." at end of Df$ add default type 4680 ! ******************************************************************** ! 4690 ! * * ! 4700 ! * SEND COMMAND MAIN SECTION * ! 4710 ! * * ! 4720 ! ******************************************************************** ! 4730 ! # This section sends the file from the HP98 to the remote kermit 4740 ! # The following variables are used from previous sections 4750 ! # Sf$ - The source file name 4760 ! # Df$ - The destination file name 4770 ! # Also the following parameters changed by SET (* or Y(0)) 4780 ! # Receiving Sending Meaning 4790 ! # Rmaxl Smaxl * Maximum packet length 4800 ! # Rto * Sto Timeout values 4810 ! # Rnpad Snpad * Number of padding characters 4820 ! # Rpadc$ Spadc$ * Pad character 4830 ! # Reol Seol * End of line character (end of packet) 4840 ! # Rqctl$ * Sqctl$ Prefix character for control characters 4850 ! 4860 ! OPEN SOURCE FILE 4870 ! ---------------- 4880 Nn=Pc=Sst=Kk=Snpad=0 4890 Rt$="" 4900 Sr=15 4910 Rrr=17 ! Initialise 4920 GOSUB Open_read 4930 IF Ff<>0 THEN Srexit! Open file 4940 GOSUB Dsend 4950 ON KEY #1 GOSUB Abort ! Display & set abort key 4960 ! 4970 ! SEND SEND_INIT PACKET 4980 ! --------------------- 4990 Send_init: Nn=0 5000 T$=Si$ 5010 T=0 5020 Ibuff$="" ! seq no, set type, clear buff 5030 GOSUB Init_pack 5040 Od$=In$ ! Set up INIT packet data 5050 GOSUB Send_pack 5060 IF Ff<>0 THEN Srexit! Send SEND-INIT 5070 ! 5080 ! DECODE ACK PACKET TO GET SEND PARAMETERS 5090 ! ---------------------------------------- 5100 GOSUB Dcd_init ! Decode INIT data 5110 ! 5120 ! SEND FILE HEADER 5130 ! ________________ 5140 Send_head: T$=Sh$ 5150 T=1 5160 Od$=Df$ ! Set packet type & data = file name 5170 GOSUB Send_pack 5180 IF Ff<>0 THEN Srexit! Send packet, exit if error 5190 ! 5200 ! SEND DATA FROM FILE 5210 ! ------------------- 5220 T$=Sd$ 5230 T=2 5240 Db$="" 5250 Ee=0 5260 Maxl=Smaxl-3 ! Set type and clear data buf 5270 Minl=INT(Maxl/2) 5280 IF Minl<1 THEN Minl=1 ! Set minimum packet length 5290 GOSUB Get_data 5300 IF Ff<>0 THEN RETURN ! Get data 5310 IF Od$="" THEN Send_eof ! If no data send end of file 5320 GOSUB Send_pack 5330 IF Ff<>0 THEN Srexit! Send packet 5340 IF LEN(Id$)=0 THEN 5290 ! No term - get more data 5350 IF (Id$[1,1]<>"Z") AND (Id$[1,1]<>"X") THEN 5290! Get more data (unless Stop) 5360 ! 5370 ! SEND END OF FILE & BREAK PACKETS 5380 ! -------------------------------- 5390 Send_eof: T$=Se$ 5400 T=3 ! Set up type = send end of file 5410 GOSUB Send_pack 5420 IF Ff<>0 THEN Srexit! Send packet 5430 T$=Sb$ 5440 T=4 5450 GOSUB Send_pack ! Set up type = break - send packet 5460 GOTO Srexit ! Jump to exit routine 5470 ! 5480 ! REPORT FILENAME ERROR 5490 ! --------------------- 5500 Errfn: Cp$="Filename error" 5510 RETURN ! Change command prompt & RETURN 5520 ! ****************************************************************** ! 5530 ! * * ! 5540 ! * RECEIVE COMMAND * ! 5550 ! * * ! 5560 ! ****************************************************************** ! 5570 ! 5580 ! EXTRACT FILENAME (IF SPECIFIED) 5590 ! ------------------------------- 5600 Rec_file: S$=TRIM$(S$) ! Strip leading & trailing blanks from params 5610 CCONTROL 2;READALL ON 5620 Line_no=1 5630 Sigj=0 5640 Span=2 5650 Sig0=0 5660 IF S$="?" THEN 5670 CALL Awrite(22,0,Rs$) 5680 RETURN ! Display receive syntax 5690 END IF 5700 Sr=17 5710 Rrr=15 5720 Sst=1 5730 GOSUB Dsend ! Initialise display 5740 Pp=FNFsplit(S$,Q$,Ll) 5750 IF Pp=0 THEN 5760 Ft=1 5770 GOTO 5920 ! Check if filename present 5780 END IF 5790 Df$=TRIM$(S$[2,Pp]) 5800 Ft=0 ! Get destination filename 5810 Pp=POS(Df$,Dt$) 5820 IF Pp=0 THEN Pp=POS(Df$,Cn$) ! Volume (.) or MSUS (:) 5830 IF Pp=0 THEN 5870 ! If none skip 5840 Vn$=Df$[Pp] 5850 IF (Pp=1) OR (LEN(Vn$)>6) THEN Errfn! Get volume name & check 5860 Df$=Df$[1,Pp-1] ! Get file name 5870 IF LEN(Df$)>10 THEN Errfn ! Check filename 5880 CALL Awrite(4,2,St$(1)&" as '"&Df$&"'") ! Display name 5890 ! 5900 ! RECEIVE SEND_INIT PACKET 5910 ! ------------------------ 5920 Rec_init: Nn=Nf=Pc=Kk=0 5930 Ibuff$="" 5940 ON KEY #1 GOSUB Abort 5950 GOSUB Init_pack 5960 A$=Si$ 5970 T=0 ! Set INIT packet, Allowable type "S" 5980 GOSUB Get_pack 5990 IF Ff<>0 THEN Srexit! Get SEND-INIT 6000 GOSUB Dcd_init ! Decode SEND-INIT packet 6010 ! 6020 ! RECEIVE FILE HEADER OR BREAK 6030 ! ---------------------------- 6040 Rec_head: A$="FBSZ" 6050 Db$="" ! Valid types F/B (S/Z prev), Clear buffer 6060 T=8 6070 GOSUB Get_pack ! Get File header or Break packet 6080 IF (Rt$=Sb$) OR (Ff<>0) THEN Srexit! If break received or error exit 6090 ! 6100 ! EXTRACT FILE NAME, CONVERT & OPEN FILE 6110 ! -------------------------------------- 6120 Sf$=Id$ 6130 Kk=0 ! Get Fn, reset byte count 6140 IF Ft=0 THEN 6150 GOTO 6390 6160 ELSE 6170 Df$=Sf$ 6180 Ll=LEN(Df$) 6190 Pp=POS(Df$,Dt$) ! Get len, pos of '.' 6200 IF Ll=0 THEN 6210 Df$=Dfn$&Dft$ 6220 GOTO 6170 ! Default Fn & Ft 6230 END IF 6240 IF Pp=0 THEN 6390 ! No '.' - no seperation 6250 IF Pp=Ll THEN 6260 Df$=Df$&Dft$ 6270 GOTO 6170 ! '.' at end add default Ft 6280 END IF 6290 IF Pp=1 THEN 6300 Df$=Dfn$&Df$ 6310 GOTO 6170 ! '.' at start add default Fn 6320 END IF 6330 F$=Df$[1,Pp-1] 6340 IF LEN(F$)>6 THEN F$=F$[1,6] ! Fn - 6 chars 6350 S$=Df$[Pp+1,Ll] 6360 IF LEN(S$)>3 THEN S$=S$[1,3] ! Ft - 3 chars 6370 Df$=F$ !&Sp$&S$ 6380 Ft=LEN(F$)+1 ! Fn Ft 6390 GOSUB Open_write 6400 IF Ff<>0 THEN Srexit! Open file 6410 CALL Awrite(4,2,St$(1)&" '"&Sf$&"' as '"&Df$&"'") ! Display file names 6420 ! 6430 ! RECEIVE DATA OR END OF FILE 6440 ! --------------------------- 6450 Rec_data: A$="DZF" 6460 T=9 ! Valid types D/Z (F prev) 6470 GOSUB Get_pack 6480 IF Ff<>0 THEN Srexit! Get packet 6490 IF Rt$=Se$ THEN 6500 GOSUB Close_write 6510 GOTO Rec_head ! If EOF close file 6520 END IF 6530 GOSUB Put_data 6540 IF Ff<>0 THEN Srexit! Store data in file 6550 GOTO Rec_data ! Get next data packet 6560 ! ***************************************************************** ! 6570 ! * * ! 6580 ! * SET/SHOW COMMANDS * ! 6590 ! * * ! 6600 ! ***************************************************************** ! 6610 Show_pars: IF S$="" THEN Sa ! If no parameters after show - show all 6620 Set: GOSUB Split 6630 S$=TRIM$(S$) ! Split parameter string 6640 Pp=FNInlist(F$,Sl$,Sp$) ! Find if option is in list 6650 IF Pp<1 THEN 6660 Df$=F$ 6670 I$=Io$ 6680 GOTO 6840 ! Illegal option 6690 END IF 6700 I$=FNXlist$(Sl$,Pp)! Get real option (ie not abbrev.) 6710 IF C=5 THEN 6830 ! If show just show 6720 Df$=S$ 6730 O=Pp ! Save option setting 6740 ! Set 6750 ON Pp GOSUB S0,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,S12,S13,S14 6760 IF Pp<1 THEN 6770 GOTO 6840 6780 ELSE 6790 Pp=0 6800 S$=Df$ ! If error or ? skip else get option 6810 END IF 6820 ! Show 6830 ON Pp+1 GOSUB Dummy,Ss0,Ss1,Ss2,Ss3,Ss4,Ss5,Ss6,Ss7,Ss8,Ss9,Ss10,Ss11,Ss12,Ss13,Ss14 6840 IF Pp>-1 THEN CALL Awrite(22,0,I$&" - "&Df$) 6850 RETURN 6860 ! ***************************************************************** ! 6870 ! * * ! 6880 ! * SET COMMAND * ! 6890 ! * * ! 6900 ! ***************************************************************** ! 6910 S0: Rto=FNPval(S$,I$,Iv$,Rto,Pp) 6920 RETURN ! Timeout 6930 S1: Rlim=FNPval(S$,I$,Iv$,Rlim,Pp) 6940 RETURN ! Retry limit 6950 S2: Ps=FNLset(S$,Sc,Pp,Oo$,Sp$,I$,Io$) 6960 RETURN ! send conversion 6970 S3: Db=FNLset(S$,Db,Pp,Oo$,Sp$,I$,Io$) 6980 RETURN ! Debug (ON/OFF) 6990 S4: Pp=0 7000 IF LEN(S$)<>1 THEN 7010 I$=Ic$ 7020 RETURN ! Prefix 7030 ELSE 7040 Sqctl$=S$ 7050 RETURN 7060 END IF 7070 S5: Seol=FNPval(S$,I$,Iv$,Seol,Pp) 7080 RETURN ! End of line 7090 S6: T=0 7100 Db$="" ! Record end marker 7110 GOSUB Split 7120 Kk=FNPval(F$,I$,Iv$,0,Pp) ! Get no 7130 IF Kk=0 THEN RETURN ! If illegal RETURN 7140 Db$=Db$&CHR$(Kk) 7150 T=T+1 ! Add to Sstring 7160 IF (S$<>"") AND (T<4) THEN 7110! If more get no 7170 Re=T 7180 Re$=Db$ 7190 Pp=7 7200 RETURN ! Set new value & RETURN 7210 S7: Fs=FNPval(S$,I$,Iv$,Fs,Pp) 7220 Nr=Fs*1024/Rl 7230 RETURN ! File size 7240 S8: Rl=FNPval(S$,I$,Iv$,Rl,Pp) 7250 Nr=Fs*1024/Rl 7260 RETURN ! Record length 7270 S9: Nr=FNPval(S$,I$,Iv$,Nr,Pp) 7280 Fs=Nr*Rl/1024 7290 RETURN ! No of records 7300 S10: Dx=FNLset(S$,Dx,Pp,Dx$,Sp$,I$,Io$) 7310 Le=Dx 7320 GOTO 7420 ! Duplex 7330 S11: Le=FNLset(S$,Le,Pp,Oo$,Sp$,I$,Io$) 7340 GOTO 7420 ! Local echo 7350 S12: Fc=FNLset(S$,Fc,Pp,Fc$,Sp$,I$,Io$) 7360 IF Fc<>0 THEN Hs=0! Flow control 7370 GOTO 7420 7380 S13: Hs=FNLset(S$,Hs,Pp,Hs$,Sp$,I$,Io$) 7390 IF Hs<>0 THEN Fc=0! Handshake 7400 GOTO 7420 7410 S14: Pt=FNLset(S$,Pt,Pp,Pt$,Sp$,I$,Io$) ! Parity 7420 GOSUB Rs_set 7430 RETURN ! Reset RS232 7440 ! 7450 ! ***************************************************************** ! 7460 ! * * ! 7470 ! * SHOW COMMAND * ! 7480 ! * * ! 7490 ! ***************************************************************** ! 7500 Sa: PRINT PAGE ! Clear screen 7510 FOR N=0 TO 14 7520 Nn=N+1 ! For each set option 7530 CALL Awrite(2+N DIV 2,40*(N MOD 2),FNXlist$((Sl$),Nn)) ! Display option 7540 ON Nn GOSUB Ss0,Ss1,Ss2,Ss3,Ss4,Ss5,Ss6,Ss7,Ss8,Ss9,Ss10,Ss11,Ss12,Ss13,Ss14 7550 CALL Awrite(2+N DIV 2,15+40*(N MOD 2),Df$) ! Display value 7560 NEXT N 7570 RETURN 7580 Ss0: Df$=VAL$(Rto) 7590 RETURN ! Timeout 7600 Ss1: Df$=VAL$(Rlim) 7610 RETURN ! Retry limit 7620 Ss2: Df$=FNXlist$(Oo$,Sc+1) 7630 RETURN ! send conversion 7640 Ss3: Df$=FNXlist$(Oo$,Db+1) 7650 RETURN ! Debug 7660 Ss4: Df$=Sqctl$ 7670 RETURN ! Prefix 7680 Ss5: Df$=VAL$(Seol) 7690 RETURN ! End of line 7700 Ss6: Df$="" ! Record end marker 7710 FOR I=1 TO Re 7720 Df$=Df$&VAL$(NUM(Re$[I,I]))&Sp$ 7730 NEXT I 7740 RETURN 7750 Ss7: Df$=VAL$(Fs)&"k" 7760 RETURN ! File Ssize 7770 Ss8: Df$=VAL$(Rl) 7780 RETURN ! Record length 7790 Ss9: Df$=VAL$(Nr) 7800 RETURN ! No of records 7810 Ss10: Df$=FNXlist$(Dx$,Dx+1) 7820 RETURN ! Duplex 7830 Ss11: Df$=FNXlist$(Oo$,Le+1) 7840 RETURN ! Local echo 7850 Ss12: Df$=FNXlist$(Fc$,Fc+1) 7860 RETURN ! Flow control 7870 Ss13: Df$=FNXlist$(Hs$,Hs+1) 7880 RETURN ! Handshake 7890 Ss14: Df$=FNXlist$(Pt$,Pt+1) 7900 RETURN ! Parity 7910 ! ***************************************************************** ! 7920 ! * * ! 7930 ! * SEND & RECEIVE SUBROUTINES * ! 7940 ! * * ! 7950 ! ***************************************************************** ! 7960 ! 7970 ! RECEIVE PACKET 7980 ! -------------- 7990 Rec_pack: Mm=0 8000 Id$="" ! Reset mark flag 8010 SET TIMEOUT 2;Tmo ! Set timeout limit 8020 ! ON TIME OUT(2) GOTO Rto 8030 B_chk: ! 8040 S=CSTAT(2,1) 8050 IF S=0 THEN 8060 WAIT Tmo/5 8070 GOTO B_chk ! If no data wait & check again 8080 END IF 8090 CREAD 2;Ibuff$ 8100 I$=Ibuff$ 8110 Ll=LEN(I$) 8120 Ii=1 ! Data length & count 8130 N_chr: Kk$=I$[Ii,Ii] ! Get character 8140 IF Kk$=Mk$ THEN 8150 Mm=1 8160 Rp$="" 8170 Jj=0 ! If mark set flag, null packet etc 8180 END IF 8190 IF Mm=0 THEN I_chr ! Mark not reached yet skip 8200 IF Kk$=Reol$ THEN E_pck ! End line recieved 8210 Rp$=Rp$&Kk$ 8220 Jj=Jj+1 ! Add char to packet inc count 8230 I_chr: Ii=Ii+1 8240 IF Ii>Ll THEN 8250 GOTO B_chk 8260 ELSE 8270 GOTO N_chr ! if no data in buf get more 8280 END IF 8290 E_pck: IF Jj<5 THEN 8030 ! packet not long enough get another 8300 ! OFF TIMER# 1 ! Halt timer 8310 IF IiRp$[Jj,Jj] THEN 8350 Rt$=FNStbit$((Rp$[Jj])) 8360 Bp=Bp+1 8370 RETURN ! set B7 type 8380 END IF 8390 Rt$=Rp$[4,4] 8400 Rn=FNUnchar((Rp$[3,3]))! Get type & sequence number 8410 Ff=0 8420 FOR Ii=5 TO Jj-1 8430 Kk$=Rp$[Ii,Ii] ! Get each charcter in data part 8440 IF Ff=0 THEN 8480 ! If prefix flag off skip 8450 IF Kk$<>Rqctl$ THEN Kk$=FNCtl$(Kk$)! If not prefix char change to ctRl 8460 Ff=0 8470 GOTO 8520 ! Skip to add to data string 8480 IF Kk$=Rqctl$ THEN 8490 Ff=1 8500 GOTO 8530 ! If prefix char set flag next char 8510 END IF 8520 Id$=Id$&Kk$ ! Add char to data string 8530 NEXT Ii 8540 RETURN ! RETURN 8550 Rto: ! OFF TIMER# 1 ! Disable timer 8560 IF Mm=1 THEN 8570 Mm=2 8580 GOTO 8010 ! Packet is being transmitted wait 8590 END IF 8600 ! IF Hs#0 THEN RESUME 10 ! If handshake enable transmit 8610 Ttmo=Ttmo+1 8620 Rt$="T" 8630 RETURN 8640 ! 8650 ! SEND PACKET 8660 ! ----------- 8670 Send_pack: Ff=0 8680 Rr=0 8690 GOSUB C_pack ! Set flag & retry, construct packet 8700 Send1: Ss=T 8710 GOSUB Disp_state ! Display state 8720 IF Db THEN 8730 CALL Awrite(Sr,0,RPT$(Sp$,320)) 8740 CALL Awrite(Sr,Ssc,Op$) ! debug display 8750 END IF 8760 GOSUB Send_buff 8770 IF Ff<>0 THEN RETURN ! Send buffer out 8780 Ss=6 8790 GOSUB Disp_state 8800 GOSUB Rec_pack ! Display, receive ACK/NAK 8810 IF (Rt$>Del$) OR (Rt$=Tm$) THEN 8950 ! Bad packet or timeout retry ? 8820 N=BINAND(Rn-BINAND(Nn,63),63) 8830 Ff=0 ! Find seq no difference 8840 IF (Rt$=Ak$) AND (N=0) OR (Rt$=Nk$) AND (N=1) THEN 8850 Pc=Nn=Nn+1 8860 RETURN ! Ok RETURN 8870 END IF 8880 IF (Rt$=Ak$) AND (N=63) THEN 8780 ! Previous ACK - Ignore 8890 IF Rt$<>Nk$ THEN 8900 Ff=4 8910 RETURN ! If not nak - wrong packet 8920 ELSE 8930 Nk=Nk+1 8940 END IF 8950 Rr=Rr+1 8960 IF Rr0 THEN Obuff$=RPT$(Spadc$,Snpad) ! Add padding if needed 9140 Obuff$=TRIM$(Op$&CHR$(Seol)) 9150 Bl=CSTAT(2,2) 9160 RETURN ! Get buffer length 9170 ! 9180 ! CLEAR INPUT BUFFER CONTENTS 9190 Clrbuf: CREAD 2;Resp$ 9200 IF Resp$<>"" THEN Clrbuf 9210 RETURN 9220 ! 9230 ! TRANSMIT BUFFER CONTENTS 9240 Send_buff: ! ------------------------ 9250 SET TIMEOUT 2;Stm 9260 ! ON TIME OUT(2) GOTO 9780 9270 GOSUB Clrbuf 9280 CWRITE 2;Obuff$ 9290 SET TIMEOUT 2;32767 9300 Ibuff$="" ! Disable timer & clear input buffer 9310 RETURN 9320 Ff=5 9330 ! OFF TIMER# 1 9340 RETURN ! Set error flag 9350 ! 9360 ! RECEIVE PACKET WITH ACK 9370 ! ----------------------- 9380 Get_pack: Rr=0 9390 Ss=T 9400 GOSUB Disp_state 9410 CALL Awrite(Rrr,0,RPT$(Sp$,320)) ! Display 9420 Ff=Pp=0 9430 GOSUB Rec_pack ! Receive packet 9440 IF Rt$=Tm$ THEN 9450 Ff=1 9460 GOTO 9660 ! If timeout retry ? 9470 END IF 9480 IF Rt$>Del$ THEN 9490 Ff=3 9500 GOTO 9660 ! If checksum error retry 9510 END IF 9520 Pp=POS(A$,Rt$) 9530 N=BINAND(Rn-Nn,63) ! Is received type valid 9540 IF (N<>0) AND (N<>63) OR (Pp=0) THEN 9550 Ff=4 9560 RETURN ! If not valid exit 9570 END IF 9580 Od$="" 9590 IF Rt$=Si$ THEN Od$=In$ ! If SEND-INIT set INIT ACK 9600 T$=Ak$ 9610 Ss=6 9620 Nn=Rn 9630 GOSUB C_pack ! Construct ACK 9640 Nn=(Nn+1) MOD 64 9650 GOTO 9730 ! Get next seq - Send ACK 9660 Rr=Rr+1 9670 IF Rr>Rlim THEN RETURN ! If retry limit exceeded exit 9680 T$=Nk$ 9690 Ss=7 9700 Od$="" 9710 Nk=Nk+1 9720 GOSUB C_pack ! Construct NAK 9730 GOSUB Disp_state 9740 IF Db THEN CALL Awrite(Sr,Ssc,Op$) ! Display state 9750 Ff=0 9760 GOSUB Send_buff 9770 IF Ff<>0 THEN RETURN ! Send ACK/NAK 9780 IF (Pp<>1) AND (Pp<>2) OR (N<>0) THEN 9390 ! If not valid get another packet 9790 Pc=Pc+1 9800 RETURN ! Inc packet count - RETURN 9810 ! ***************************************************************** ! 9820 ! * * ! 9830 ! * CONSTRUCT & DECODE INITIALISATION PACKETS * ! 9840 ! * * ! 9850 ! ***************************************************************** ! 9860 ! 9870 ! SET UP SEND-INIT PACKET (S(0),Y(0)) 9880 ! ----------------------------------- 9890 Init_pack: Ttmo=Nk=Bp=0 ! Timeouts naks & bad packets 9900 Tmo=Rto*1000 ! Set timeout for receiving 9910 In$=FNChar$(Rmaxl) ! Packet = maximum length 9920 In$=In$&FNChar$(Sto) ! + send timeout 9930 In$=In$&FNChar$(Rnpad)&FNCtl$(Rpadc$) ! + no of pad chars & char 9940 In$=In$&FNChar$(Seol)&Sqctl$ ! + end of line & ctRl qoute 9950 Smaxl=80 9960 Snpad=0 9970 Spadc$=Null$ 9980 Reol=13 9990 Rqctl$="#" ! Defaults 10000 RETURN 10010 ! 10020 ! EXTRACT PARAMETERS FROM INIT PACKET (S(0),Y(0)) 10030 ! ----------------------------------------------- 10040 Dcd_init: Ll=LEN(Rp$)-5 10050 IF Ll=0 THEN RETURN ! If no params RETURN 10060 IF Ll<7 THEN ! Change params 10070 ON Ll GOTO Maxl,Tmo,Npad,Padc,Elc,Qctl 10080 END IF 10090 Qctl: IF Rp$[10,10]<>Sp$ THEN Rqctl$=Rp$[10,10]! Prefix char 10100 Elc: IF Rp$[9,9]<>Sp$ THEN Seol=FNUnchar((Rp$[9,9]))! End of line 10110 Padc: IF Rp$[8,8]<>Sp$ THEN Spadc$=FNCtl$((Rp$[8,8]))! Pad character 10120 Npad: IF Rp$[7,7]<>Sp$ THEN Snpad=FNUnchar((Rp$[7,7]))! No of pad chars 10130 Tmo: IF Rp$[6,6]<>Sp$ THEN Rto=FNUnchar((Rp$[6,6]))! Receive timeout 10140 Maxl: IF Rp$[5,5]<>Sp$ THEN Smaxl=FNUnchar((Rp$[5,5]))! Max packet length 10150 RETURN 10160 ! 10170 ! EXIT ROUTINE FOR SEND & RECEIVE 10180 ! ------------------------------- 10190 Srexit: IF (Ff=0) OR (Ff=5) THEN 10280! If ok or send problem skip 10200 IF (Ff<>4) OR (Rt$<>Er$) THEN 10230! If not error packet skip 10210 CALL Awrite(19,0,"Error message from remote - "&Id$) 10220 GOTO 10310! Display 10230 Od$=Em$(Ff) 10240 T$=Er$ 10250 T=5 ! Set up error packet 10260 GOSUB C_pack 10270 GOSUB Send_buff ! Construct and send error packet 10280 CALL Awrite(19,0,Em$(Ff)) ! Display message (ok or error) 10290 BEEP !(Ff#1)*20+20,200 ! Beep (lower for error) 10300 IF (Ff>6) AND (Ff<23) THEN CALL Awrite(19,LEN(Em$(Ff))+1,"(error no - "&VAL$(Ee)&")") 10310 CCONTROL 2;READALL OFF 10320 RETURN ! RETURN to command section 10330 ! 10340 ! ABORT TRANSFER 10350 ! -------------- 10360 Abort: Ff=24 10370 RETURN ! Set error flag to abort 10380 ! **************************************************************** ! 10390 ! 10400 ! SET UP RS232 INTERFACE 10410 ! ---------------------- 10420 ! **************************************************************** ! 10430 Rs_set: CDISCONNECT 2;HOLD 10440 ! CCOM 4428 10450 CMODEL ASYNC,2;ALERTN=1,CHECK=1,MEMLIMIT=2000,INBUFFER=1240,TBUFFER=520 10460 CCONNECT 2;HANDSHAKE OFF,SPEED=9600 10470 CCONTROL 2;XON 10480 CWRITE 2;ENDLINE 10490 SYSTEM TIMEOUT OFF 10500 SET TIMEOUT 2;32767 10510 RETURN 10520 ! 10530 ! DUMMY SUBROUTINE 10540 ! ---------------- 10550 Dummy: RETURN 10560 ! 10570 ! SET UP KEYS TO DUMMY ROUTINE 10580 ! ---------------------------- 10590 Dkeys: FOR Ii=1 TO 14 10600 ON KEY #Ii GOSUB Dummy 10610 NEXT Ii 10620 RETURN 10630 ! ******************************************************************** ! 10640 ! * * ! 10650 ! * ROUTINES FOR DISPLAYING CURRENT SENDING STATE * ! 10660 ! * * ! 10670 ! ******************************************************************** ! 10680 ! # The following variables are used by these routines 10690 ! # S - State (0/1) sending or waiting for ACK 10700 ! # T - Type of packet being sent (0-S,1-F,2-D,3-Z,4-B) 10710 ! # Nn - Current sequence number (not modulo 64) 10720 ! # Rr - No of retries for current packet 10730 ! # Nk - No of NAKs received 10740 ! # Tm - No of timeouts 10750 ! # Bp - No of corrupted packets received 10760 ! # Kk - No of bytes sent 10770 ! # Sf$ - Source file specifier 10780 ! # Df$ - Destination '' '' 10790 ! 10800 ! SET UP SCREEN FOR SEND DISPLAY 10810 ! ------------------------------ 10820 Dsend: PRINT PAGE 10830 CALL Awrite(1,2,"HP98 Kermit - "&St$(St)&" file") 10840 CALL Awrite(2,2,RPT$("-",LEN(St$(St))+19)) 10850 IF St=0 THEN CALL Awrite(4,2,St$(St)&" "&Sf$&" as "&Df$) 10860 CALL Awrite(6,2,"Current action :") 10870 CALL Awrite(6,46,"Retries :") 10880 CALL Awrite(8,2,"Packets :") 10890 CALL Awrite(8,40,"NAKs :") 10900 CALL Awrite(9,2,"Bytes :") 10910 CALL Awrite(9,40,"Timeouts :") 10920 CALL Awrite(10,40,"Bad packets :") 10930 CALL Awrite(8,10,St$(St)) 10940 CALL Awrite(8,45,St$(1-St)) 10950 CALL Awrite(9,8,St$(St)) 10960 RETURN 10970 ! 10980 ! DISPLAY SENDING STATE 10990 ! --------------------- 11000 Disp_state: Tt=(Ss>7) OR (Ss=6) AND (St=0) OR (Ss=0) AND (St=1)!Wait or Send (1/0) 11010 IF Tt THEN 11020 D$="Wait for " 11030 ELSE 11040 D$="Send " 11050 END IF 11060 CALL Awrite(6,18,RPT$(Sp$,26)) ! Clear old action 11070 CALL Awrite(6,18,D$&A$(Ss)) 11080 CALL Awrite(6,56,VAL$(Rr)) ! Display action & Retries 11090 CALL Awrite(8,21,VAL$(Pc)) 11100 CALL Awrite(8,56,VAL$(Nk)) ! Packets & NAKs 11110 CALL Awrite(9,21,FNKb$(Kk)) 11120 CALL Awrite(9,56,VAL$(Ttmo)) ! Bytes & timeouts 11130 CALL Awrite(10,56,VAL$(Bp)) ! Bad packets received 11140 RETURN 11150 ! **************************************************************** ! 11160 ! * * ! 11170 ! * SUBROUTINES FOR DISK ACCESS * ! 11180 ! * * ! 11190 ! **************************************************************** ! 11200 ! 11210 ! OPEN FILE FOR READING 11220 ! --------------------- 11230 Open_read: ON ERROR GOTO Fserr 11240 SELECT Data_type 11250 CASE 1 11260 ASSIGN #1 TO Sf$ ! Try to open file 11270 CASE 2 11280 CALL Samfile(Sig(*),Sig1(*),1,Info$(*),File$,Title$,Line1$,Line2$,Line3$,Sf$) 11290 Span=VAL(Info$(2)) 11300 END SELECT 11310 OFF ERROR 11320 Ff=0 11330 RETURN ! If success RETURN 11340 ! 11350 ! GET PACKET OF DATA FROM FILE 11360 ! ---------------------------- 11370 Get_data: Bb=0 11380 Ll=LEN(Db$) 11390 IF Ll>=Minl THEN 12000 ! If enough data output 11400 IF Data_type=2 THEN 11550 11410 ON ERROR GOTO 12140 ! Set 8-bit data flag 11420 Tt=TYP(1) 11430 IF Tt<>3 THEN 11520! Not EOF get more data 11440 Ee=1 11450 OFF ERROR ! Error trap off 11460 IF Ll=0 THEN ! Get any data left 11470 Od$="" 11480 RETURN 11490 ELSE 11500 GOTO 12010 11510 END IF 11520 IF Tt=1 THEN 11870 ! If number skip 11530 READ #1;S$ 11540 GOTO 11630 11550 IF Sigj<=Span THEN 11620 11560 IF Ll=0 THEN 11570 Od$="" 11580 RETURN 11590 ELSE 11600 GOTO 12010 11610 END IF 11620 CALL Encode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Sig(*),Sigj,Line_no,Rmaxl,Span,Sig0) 11630 S$=S$&Re$ 11640 L=LEN(S$) 11650 Kk=Kk+L ! Read string variable 11660 FOR Ii=1 TO L 11670 Kk$=S$[Ii,Ii] ! Get character 11680 IF Kk$<=Del$ THEN ! If 8-bit reset b7 11690 GOTO 11780 11700 ELSE 11710 Kk$=FNStbit$(Kk$) 11720 END IF 11730 IF Bb=0 THEN 11740 PRINT "Eight bit data" 11750 BEEP 11760 Bb=1 ! WaRn if first 8-bit 11770 END IF 11780 IF Kk$Pf$ THEN 12260 Nf=0 12270 GOTO 12340 ! If new name reset count skip 12280 END IF 12290 IF Nf>99 THEN 12300 Ff=6 12310 RETURN ! If cannot renumber -exit 12320 END IF 12330 Df$=FNNofile$(Df$,Nf,Ft,Pp,Np) ! Renumber file 12340 ON ERROR GOTO Fserr ! Set filing system error trap 12350 IF Data_type<>1 THEN 12380 12360 CREATE Df$,Nr,Rl ! Try to create file 12370 ASSIGN #1 TO Df$ ! If successfull open file 12380 OFF ERROR 12390 Pf$=Df$ ! Save name 12400 RETURN 12410 ! 12420 ! WRITE DATA TO FILE 12430 ! ------------------ 12440 Put_data: SELECT Data_type 12450 CASE 1 12460 Db$=Db$&Id$ 12470 Kk=Kk+LEN(Id$) ! Place data in buffer 12480 ON ERROR GOTO Fserr ! Set error trap 12490 Pp=POS(Db$,Re$) ! Find end of record 12500 IF Pp=0 THEN 12510 OFF ERROR 12520 RETURN ! IF no EOR exit 12530 END IF 12540 IF Pp>1 THEN ! If data before EOR get it 12550 S$=Db$[1,Pp-1] 12560 ELSE 12570 S$="" 12580 END IF 12590 PRINT #1;S$ 12600 Ll=LEN(Db$) ! Output to disk, find buff length 12610 IF Ll>Pp+(Re-1) THEN ! If any data left save 12620 Db$=Db$[Pp+Re] 12630 ELSE 12640 Db$="" 12650 END IF 12660 GOTO 12490 12670 CASE 2 12680 Db$=Id$ 12690 S$=Db$ 12700 CALL Decode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Left$,Sig(*),Sigj,Line_no,Pp,Inf,Sig0) 12710 Db$="" 12720 END SELECT 12730 RETURN 12740 ! 12750 ! CLOSE FILE 12760 ! ---------- 12770 Close_write: ON ERROR GOTO Fserr ! Set up error trap 12780 IF LEN(Db$)>0 THEN 12790 SELECT Data_type 12800 CASE 1 12810 PRINT #1;Db$ 12820 Db$="" ! Write any remaining data 12830 ASSIGN #1 TO * ! Close file 12840 CASE 2 12850 CALL Decode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Left$,Sig(*),Sigj,Line_no,Pp,Inf,Sig0) 12860 Db$="" 12870 PRINT "File ready to be stored" 12880 PAUSE 12890 ! CALL Samfile(Sig(*),Sig1(*),2,Span,Info$(*),File$,Title$,Line1$,Line2$,Line3$,Sf$,Df$) 12900 END SELECT 12910 END IF 12920 OFF ERROR 12930 RETURN 12940 ! 12950 ! FILING SYSTEM ERROR HANDLING ROUTINE 12960 ! ------------------------------------ 12970 Fserr: Ee=ERRN 12980 Ll=ERRL 12990 OFF ERROR ! Get error no & line no 13000 IF (Ee=54) AND (Ll=12360) THEN 12290! If DUP NAME & CREATE -retry new name 13010 Pp=POS(Fse$,CHR$(Ee)) ! Find pos of error in valid string 13020 IF Pp>0 THEN 13030 Ff=6+Pp 13040 RETURN ! If valid error - set flag & RETURN 13050 END IF 13060 RESUME INTERACTIVE 13070 PRINT "UNEXPECTED ERROR !" 13080 PRINT USING "6A,K,9A,K";"ERROR ",Ee," AT LINE ",Ll 13090 END 13100 ! 13110 ! **************************************************************** ! 13120 ! * * ! 13130 ! * FUNCTIONS FOR CODING & DECODING PACKETS * ! 13140 ! * * ! 13150 ! **************************************************************** ! 13160 ! 13170 ! CONVERT NUMBER TO PRINTABLE CHARACTER 13180 ! ------------------------------------- 13190 Char:DEF FNChar$(INTEGER Nn)=CHR$(Nn+32) ! Character = no + 32 13200 ! 13210 ! CONVERT CHARACTER TO NUMBER 13220 ! --------------------------- 13230 Unchar:DEF FNUnchar(Cc$)=NUM(Cc$)-32 ! no = char - 32 13240 ! 13250 ! SWAP BETWEEN CONTROL CHARACTER AND PRINTABLE CHARACTER 13260 ! ------------------------------------------------------ 13270 Ctl:DEF FNCtl$(Cc$)=CHR$(BINEOR(NUM(Cc$),64)) ! xor bit 6 13280 ! 13290 ! SET / RESET TOP BYTE OF CHARACTER 13300 ! --------------------------------- 13310 Stbit:DEF FNStbit$(Cc$)=CHR$(BINEOR(NUM(Cc$),128)) ! xor bit 7 13320 ! FUNCTION TO RENUMBER FILE 13330 ! ------------------------- 13340 Nofile:DEF FNNofile$(F$,INTEGER Nf,Ft,Pp,Np) 13350 IF Nf>0 THEN 13430 ! If Not first numbering skip 13360 IF Ft<2 THEN 13410 ! If Not Fn Ft format skip 13370 Np=Pp=Ft 13380 IF Np>5 THEN Np=5 ! Find position of Ft 13390 F$[Np]="00"&F$[Pp] 13400 GOTO 13440 ! Insert 00 13410 Np=LEN(F$)+1 13420 IF Np>9 THEN Np=9 ! Find position of no 13430 F$[Np,Np+1]=VAL$(Nf DIV 10)&VAL$(Nf MOD 10) 13440 Nf=Nf+1 13450 RETURN F$ ! Inc count RETURN new name 13460 FNEND 13470 ! 13480 ! FUNCTION TO CHECK FOR "c..." 13490 ! ---------------------------- 13500 Fsplit:DEF FNFsplit(F$,Q$,INTEGER Ll) 13510 Pp=0 13520 Ll=LEN(F$) ! Set p get length of string 13530 IF Ll<3 THEN 13570 ! Must be at least "?" (? - any char) 13540 IF F$[1,1]<>Q$ THEN 13570! Must start with " 13550 Pp=POS(F$[2],Q$) 13560 IF Pp<2 THEN Pp=0 ! Find position of next " ("" invalid) 13570 RETURN Pp ! RETURN position 13580 FNEND 13590 ! 13600 ! FIND POSITION OF OPTION IN LIST OF VALID OPTIONS 13610 ! ------------------------------------------------ 13620 Inlist:DEF FNInlist(Cc$,Ll1$,Sp$) 13630 DIM Ll$[164] 13640 Ll$=Ll1$ 13650 Cc$=UPC$(Cc$) 13660 Ll=Jj=1 13670 L=LEN(Ll$) ! Cc$ - uppercase, set count etc 13680 IF Cc$<>"?" THEN 13990! If not '?' skip 13690 Jj=-1 13700 IF L<68 THEN 13710 P=L 13720 GOTO 13850 ! If list fits display 13730 END IF 13740 CALL Awrite(22,0,RPT$(Sp$,160)) ! Clear screen area 13750 Pp=POS(Ll$[Ll],", ") ! Find ', ' 13760 IF Pp=0 THEN 13770 P=L 13780 GOTO 13850 ! If end skip 13790 END IF 13800 Ll=Ll+Pp 13810 IF Ll<68 THEN 13820 P=Ll-1 13830 GOTO 13740 ! If fits get next 13840 END IF 13850 CALL Awrite(22,0,"Options :- "&Ll$[1,P]) 13860 IF P=L THEN 14110 ! display 13870 Ll$=Ll$[P+2] 13880 L=L-P-1 13890 Ll=1 13900 CALL Awrite(23,0,"Press CONT for more") ! 13910 ! Kk$=KBD$ 13920 ! IF Kk$="" THEN ! wait for key 13930 ! GOTO 14110 13940 ! ELSE 13950 ! GOTO 13940 13960 ! END IF 13970 INPUT "",Dum 13980 GOTO 13740 13990 Cp=POS(Ll$[Ll],",") ! Find pos of ',' 14000 IF Cp>0 THEN ! Adjust - if at end pos = end 14010 Cp=Cp+Ll-1 14020 ELSE 14030 Cp=L 14040 END IF 14050 Pp=POS(Ll$[Ll,Cp],Cc$) 14060 IF Pp=1 THEN 14110 ! Is Cc$ same as part of option 14070 Jj=Jj+1 14080 Ll=Cp+2 14090 IF Ll"?" THEN 14210! If not ? get value 14180 Df$="value" 14190 Pp=0 ! On RETURN OPTION - value will be printed 14200 GOTO 14280 14210 Cc=NUM(Cc$) ! Check for numeric (0-9) 14220 IF (Cc<48) OR (Cc>58) THEN 14230 I$=Iv$ 14240 Pp=0 14250 GOTO 14280 ! Illegal value ? 14260 END IF 14270 Oo=VAL(Cc$) ! Set new value 14280 RETURN Oo ! RETURN value (If error then old value RETURNed) 14290 FNEND 14300 ! 14310 ! SET VARIABLE FROM LIST 14320 ! ---------------------- 14330 Lset:DEF FNLset(Cc$,INTEGER Oo,Pp,Ll$,Sp$,I$,Io$) 14340 Pp=FNInlist(Cc$,Ll$,Sp$) 14350 IF Pp<1 THEN 14360 I$=Io$ 14370 ELSE 14380 Oo=Pp-1 14390 END IF 14400 RETURN Oo 14410 FNEND 14420 ! 14430 ! DISPLAY OPTION FROM LIST 14440 ! ------------------------ 14450 Xlist: DEF FNXlist$(Ll$,INTEGER Pp) 14460 Jj=1 14470 Ll=1 14480 L=LEN(Ll$) ! Set count, last pos & length 14490 Cp=POS(Ll$[Ll],", ") ! Position of ', ' 14500 IF Cp>0 THEN ! Set cp to end of option 14510 Cp=Cp+Ll-2 14520 ELSE 14530 Cp=L 14540 END IF 14550 IF Jj=Pp THEN 14560 RETURN Ll$[Ll,Cp] 14570 GOTO 14620 14580 END IF 14590 Jj=Jj+1 14600 Ll=Cp+3 14610 IF Ll=30 THEN 15370 Line_no=7 15380 GOTO 15410 15390 END IF 15400 GOTO 15440 15410 Span=VAL(Info$(2)) 15420 Span2=INT(Span) 15430 CALL Arrfill(S$,Sig(*),Sigj,Span2,Sig0,Left$) 15440 SUBEND 15450 Encode:SUB Encode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),INTEGER Sig(*),J,Line_no,Maxl,Span,Sig0) 15460 INTEGER L,S 15470 COM Cr$[1],Lf$[1],INTEGER Bias,Bias2,Bias3,Lb1,Ub1,Lb2,Ub2,A1,A2,A3,Asoff 15480 S$="" 15490 SELECT Line_no 15500 CASE 1 15510 S$[1,10]="1"&TRIM$(Dnumbr$)&File$ 15520 S$[11]=Title$&Cr$&Lf$ 15530 CASE 2 15540 S$=Line1$[1,80] 15550 IF S$="" THEN S$=" " 15560 CASE 3 15570 S$=Line2$[1,80] 15580 IF S$="" THEN S$=" " 15590 CASE 4 15600 S$=Line3$[1,80] 15610 IF S$="" THEN S$=" " 15620 CASE 5 15630 FOR I=1 TO 15 15640 S$[8*I-7;8]=Info$(I) 15650 NEXT I 15660 CASE 6 15670 FOR I=16 TO 30 15680 S$[8*(I-15)-7;8]=Info$(I) 15690 NEXT I 15700 CASE 7 15710 FOR I=31 TO 45 15720 S$[8*(I-30)-7;8]=Info$(I) 15730 NEXT I 15740 CASE 8 15750 FOR I=46 TO 50 15760 S$[8*(I-45)-7;8]=Info$(I) 15770 NEXT I 15780 CASE ELSE 15790 IF J>Span THEN 15980 15800 S=Sig(J)-Sig0 15810 Sig0=Sig(J) 15820 IF (SUb1) THEN 15850 15830 Cn$=CHR$(ABS(S)+Bias) 15840 GOTO 15920 15850 IF (SUb2) THEN 15880 15860 Cn$=CHR$(ABS(S) DIV A2+Bias2)&CHR$(ABS(S) MOD A2+Bias) 15870 GOTO 15920 15880 T=ABS(S) 15890 Cn$=CHR$(T DIV A3+Bias3) 15900 T=T MOD A3 15910 Cn$=Cn$&CHR$(T DIV A2+Bias)&CHR$(T MOD A2+Bias) 15920 IF S<0 THEN Cn$[1,1]=CHR$(NUM(Cn$)+Asoff) 15930 S$=S$&Cn$ 15940 J=J+1 15950 L=LEN(S$) 15960 IF L>=Maxl THEN 15980 15970 GOTO 15790 15980 END SELECT 15990 Line_no=Line_no+1 16000 SUBEND 16010 Linefill:SUB Linefill(S$,Line$,Left$,P0) 16020 DIM Reol$[2] 16030 S$=TRIM$(Left$&S$) 16040 Left$="" 16050 Reol$=CHR$(13)&CHR$(10) 16060 P0=POS(S$,Reol$) 16070 L0=LEN(S$) 16080 L=P0-1 16090 IF P0 THEN 16100 IF L0<>2 THEN 16130 16110 Left$="" 16120 GOTO 16190 16130 Left$=S$[P0+2,L0] 16140 Line$=Line$&S$[1,L] 16150 T=LEN(Line$) 16160 Line$=Line$&RPT$(" ",256-T) 16170 ELSE 16180 Left$=S$[1,L0] 16190 END IF 16200 S$="" 16210 SUBEND 16220 Infofill:SUB Infofill(S$,Info$(*),INTEGER I,Left$) 16230 S$=Left$&S$ 16240 Cr$=CHR$(13) 16250 Lf$=CHR$(10) 16260 P=POS(S$,Cr$) 16270 IF P=0 THEN 16300 16280 S$[P]=S$[P+1] 16290 GOTO 16260 16300 P=POS(S$,Lf$) 16310 IF P=0 THEN 16340 16320 S$[P]=S$[P+1] 16330 GOTO 16300 16340 L=LEN(S$) 16350 IF L<8 THEN 16450 16360 I=I+1 16370 IF I>30 THEN 16450 16380 Info$(I)=S$[1,8] 16390 IF L>8 THEN S$=S$[9] 16400 IF L=8 THEN 16410 S$="" 16420 GOTO 16450 16430 END IF 16440 GOTO 16340 16450 Left$=S$ 16460 S$="" 16470 SUBEND 16480 Arrfill:SUB Arrfill(S$,INTEGER Sig(*),J,Span,Sig0,Left$) 16490 INTEGER Pt,P,L,C1,Nc,T,S 16500 COM Cr$[1],Lf$[1],INTEGER Bias,Bias2,Bias3,Lb1,Ub1,Lb2,Ub2,A1,A2,A3,Asoff 16510 S$=Left$&S$ 16520 Pt=POS(S$,Cr$) 16530 IF Pt=0 THEN 16560 16540 S$[Pt]=S$[Pt+1] 16550 GOTO 16520 16560 Pt=POS(S$,Lf$) 16570 IF Pt=0 THEN 16600 16580 S$[Pt]=S$[Pt+1] 16590 GOTO 16560 16600 P=0 16610 L=LEN(S$) 16620 IF L=0 THEN 16860 16630 C1=NUM(S$[P+1])-Bias 16640 Nc=C1 DIV A1+1 16650 C1=C1 MOD A1 16660 T=C1 16670 IF C1>=Asoff THEN C1=C1-Asoff 16680 IF LC1 THEN S=-S 16810 Sig(J)=S+Sig0 16820 Sig0=Sig(J) 16830 J=J+1 16840 IF J>Span THEN 16860 16850 GOTO 16610 16860 Left$=S$ 16870 S$="" 16880 SUBEND 16890 Get_info:SUB Get_info(Fnumber,Auto,Ins$(*),INTEGER Medium(*),Hpfile(*)) 16891 DIM Comms2$[30],Cr$[1],Lf$[1],Fname$[10] 16892 Cr$=CHR$(13) 16893 Lf$=CHR$(10) 16900 ON ERROR GOSUB Get_info_err 16910 Auto=1 16920 ASSIGN #3 TO "DECNUM:T" 16930 IF NOT Auto THEN RETURN 16940 READ #3;Fnumber$ 16950 Fnumber=VAL(Fnumber$) 16960 ASSIGN * TO #3 16970 ASSIGN #3 TO "DEC1:T" 16980 FOR I=1 TO Fnumber 16990 READ #3,I;Comms2$ 17000 P=POS(Comms2$,Cr$&Lf$) 17010 IF P<=0 THEN Get_info_ret 17020 Send$=Comms2$[1,P-1] 17030 IF Send$="1" THEN Ins$(I)="RECEIVE" 17031 IF Send$="2" THEN Ins$(I)="SEND" 17032 Comms2$[P,P+1]=" " 17033 P1=POS(Comms2$,Cr$&Lf$) 17034 Fname$=Comms2$[P+2,P1-1] 17035 Ins$(I)=Ins$(I)&" "&Fname$ 17036 Comms2$[P1,P1+1]=" " 17037 P2=POS(Comms2$,Cr$&Lf$) 17038 Medium$=Comms2$[P1+2,P2-1] 17039 Medium(I)=VAL(Medium$) 17040 Comms2$[P2,P2+1]=" " 17041 P3=POS(Comms2$,Cr$&Lf$) 17042 F1$=Comms2$[P2+2,P3-1] 17043 Hpfile(I)=VAL(F1$) 17044 NEXT I 17045 OFF ERROR 17046 ASSIGN * TO #3 17047 Get_info_ret: SUBEXIT 17048 Get_info_err: IF (ERRN=80) OR (ERRN=56) THEN 17049 Auto=0 17050 OFF ERROR 17051 SUBEXIT 17052 END IF 17053 PRINT "UNEXPECTED ERROR IN LINE ";ERRL 17054 PRINT "ERROR NUMBER ";ERRN 17065 STOP 17089 SUBEND 17090 SUB Dummy2 17100 SUBEND 17110 Samfile:SUB Samfile(INTEGER Sig(*),Sig1(*),D,Info$(*),File$,Title$,Line1$,Line2$,Line3$,Tf$) 17120 DIM Line4$[200],Line5$[200],Pline1$[200],Pline2$[200],Pline2a$[100] 17130 DIM Pline2b$[100],Pline3$[100],Notes$[1500],Data$[1500],Dir$[1500] 17140 DIM Cr$[1],Lf$[1],Di$[1500],Dir1$[320] 17150 Cr$=CHR$(13) 17160 Lf$=CHR$(10) 17170 Bl$=CHR$(130) 17180 Clr$=CHR$(128) 17190 ON D GOSUB Fetch,Openfile 17200 SUBEXIT 17210 Info_array: ! Sets up INFO(*) for DUMMY2 for Spectra 17220 FIXED 2 17230 Info$(1)=VAL$(Tp) 17240 Info$(2)=VAL$(Rnge) 17250 Info$(3)=VAL$(V1) 17260 Info$(4)=VAL$(V2) 17270 Info$(5)=VAL$(C1) 17280 Info$(6)=VAL$(C2) 17290 Info$(7)=VAL$(S) 17300 Info$(8)=VAL$(Smo) 17310 Info$(9)=VAL$(Ex) 17320 Info$(10)=VAL$(Sw) 17330 Info$(11)=VAL$(Tm) 17340 Info$(12)=VAL$(F1) 17350 Info$(13)=VAL$(D1) 17360 Info$(14)=VAL$(Epass) 17370 Info$(15)=VAL$(Ret) 17380 Info$(16)=VAL$(Nor) 17390 STANDARD 17400 GOTO Fetch_dir_redim 17410 Info_array1: ! Sets up INFO(*) for linescans 17420 FIXED 2 17430 Info$(1)=VAL$(Tp) 17440 Info$(2)=VAL$(Xmax) 17450 Info$(3)=VAL$(Ymin) 17460 Info$(4)=VAL$(Ymax) 17470 Info$(5)=VAL$(Smo) 17480 Info$(6)=VAL$(Ex) 17490 Info$(7)=VAL$(Con) 17500 Info$(8)=VAL$(Dt) 17510 Info$(9)=VAL$(F1) 17520 Info$(10)=VAL$(D1) 17530 Info$(11)=VAL$(Epass) 17540 Info$(12)=VAL$(Ret) 17550 Info$(13)=VAL$(Nor) 17560 Info$(14)=VAL$(Mag) 17570 Info$(15)=VAL$(Dirn) 17580 Info$(16)=VAL$(Ea) 17590 Info$(17)=VAL$(Eb) 17600 STANDARD 17610 GOTO Fetch_dir_redim 17620 Info_array2: ! Sets up INFO(*) for Images 17630 FIXED 2 17640 Info$(1)=VAL$(Tp) 17650 Info$(2)=VAL$(M*N) 17660 Info$(3)=VAL$(M) 17670 Info$(4)=VAL$(N) 17680 Info$(5)=VAL$(Dt) 17690 Info$(6)=VAL$(F1) 17700 Info$(7)=VAL$(D1) 17710 Info$(8)=VAL$(Epass) 17720 Info$(9)=VAL$(Ret) 17730 Info$(10)=VAL$(Nor) 17740 Info$(11)=VAL$(Mag) 17750 Info$(12)=VAL$(Ea) 17760 IF Tp=6 THEN Info$(12)=VAL$(E) 17770 Info$(13)=VAL$(Eb) 17780 Info$(14)=VAL$(Hist) 17790 Info$(15)=VAL$(Stepx) 17800 Info$(16)=VAL$(Stepy) 17810 Info$(17)=VAL$(Startx) 17820 Info$(18)=VAL$(Starty) 17830 Info$(19)=VAL$(Nsets) 17840 Info$(20)=VAL$(No_subims) 17850 STANDARD 17860 GOTO Fetch_dir_redim 17870 ! ------------------------------------------------------------------- 17880 Openfile: ! Converts to SAM Format 17890 PRINT PAGE 17900 PRINT TAB(20),"FILING DATA IN SAM FORMAT",LIN(1) 17910 PRINT TAB(19),"ANSWER ANY QUESTIONS Y OR N.",LIN(2) 17920 Send=0 17930 Title$=TRIM$(Title$)&Cr$&Lf$ 17940 Line1$=TRIM$(Line1$)&Cr$&Lf$ 17950 Line2$=TRIM$(Line2$)&Cr$&Lf$ 17960 Line3$=TRIM$(Line3$)&Cr$&Lf$ 17970 PRINT TAB(10),"FILE RECEIVED IS: ",LIN(1) 17980 PRINT Title$;Line1$;Line2$;Line3$,LIN(5) 17990 ! Now convert data in Info$(*) to SAM Format 18000 FOR I=1 TO 29 18010 IF Info$(I)="" THEN 18040 18020 Info(I)=VAL(Info$(I)) 18030 NEXT I 18040 Tp=INT(Info(1)) 18050 IF Tp=1 THEN Spectrum 18060 IF Tp=2 THEN Line_scan 18070 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) THEN Image 18080 PRINT TAB(10),Title$ 18090 PRINT TAB(10),"File type not recognised" 18100 Message$="File type not recognised" 18110 GOSUB Message 18120 GOSUB Kjob 18130 ! 18140 Gosub_store: GOSUB Store 18150 PRINT "CONTROL PASSED BACK TO DEC PROGRAMME. " 18160 PRINT "ANSWER QUESTIONS YES OR NO UNTIL TOLD OTHERWISE" 18170 RETURN 18180 ! -------------------------------------------------------------- 18190 ! Make up data for spectrum 18200 Spectrum: ! 18210 Tp=INT(Info(1)) 18220 Rnge=INT(Info(2)) 18230 V1=INT(Info(3)) 18240 V2=INT(Info(4)) 18250 C1=INT(Info(5)) 18260 C2=INT(Info(6)) 18270 S=Info(7) 18280 Smo=INT(Info(8)) 18290 Ex=INT(Info(9)) 18300 Sw=INT(Info(10)) 18310 Tm=INT(Info(11)) 18320 F1=INT(Info(12)) 18330 D1=INT(Info(13)) 18340 Epass=INT(Info(14)) 18350 Ret=INT(Info(15)) 18360 Nor=INT(Info(16)) 18370 Iturn=INT(Info(27)) 18380 Inum=INT(Info(28)) 18390 J0=INT(Info(29)) 18400 GOTO Gosub_store 18410 ! -------------------------------------------------------------- 18420 Line_scan:! Makes up data for linescan 18430 Tp=INT(Info(1)) 18440 Xmax=INT(Info(2)) 18450 Ymin=INT(Info(3)) 18460 Ymax=INT(Info(4)) 18470 Smo=INT(Info(5)) 18480 Ex=INT(Info(6)) 18490 Con=INT(Info(7)) 18500 Dt=INT(Info(8)) 18510 F1=INT(Info(9)) 18520 D1=INT(Info(10)) 18530 Epass=INT(Info(11)) 18540 Ret=INT(Info(12)) 18550 Nor=INT(Info(13)) 18560 Mag=INT(Info(14)) 18570 Dirn=INT(Info(15)) 18580 Ea=INT(Info(16)) 18590 Eb=INT(Info(17)) 18600 GOTO Gosub_store 18610 ! ------------------------------------------------------------------ 18620 Image: ! Makes up data for image 18630 Tp=INT(Info(1)) 18640 M=INT(Info(3)) 18650 N=INT(Info(4)) 18660 Dt=INT(Info(5)) 18670 F1=INT(Info(6)) 18680 D1=INT(Info(7)) 18690 Epass=INT(Info(8)) 18700 Ret=INT(Info(9)) 18710 Nor=INT(Info(10)) 18720 Mag=INT(Info(11)) 18730 Ea=INT(Info(12)) 18740 Eb=INT(Info(13)) 18750 Hist=INT(Info(14)) 18760 Stepx=INT(Info(15)) 18770 Stepy=INT(Info(16)) 18780 Startx=INT(Info(17)) 18790 Starty=INT(Info(18)) 18800 Nsets=INT(Info(19)) 18810 No_subims=INT(Info(20)) 18820 GOTO Gosub_store 18830 ! ----------------------------------------------------------------- 18840 P_spectrum:! Sets up Dir$ for spectrum 18850 Pline1$="10 Fl: READ Tp,Rnge,V1,V2,C1,C2,S,Smo,Ex,Sw,Tm,F1,D1,Epass,Ret,Nor" 18860 Pline2a$="20 DATA 1,"&VAL$(Rnge)&","&VAL$(V1)&","&VAL$(V2)&","&VAL$(C1)&","&VAL$(C2)&","&VAL$(S)&","&VAL$(Smo)&","&VAL$(Ex)&","&VAL$(Sw)&"," 18870 Pline2b$=VAL$(Tm)&","&VAL$(F1)&","&VAL$(D1)&","&VAL$(Epass)&","&VAL$(Ret)&","&VAL$(Nor) 18880 Pline2$=Pline2a$&Pline2b$ 18890 Pline3$="30 RETURN" 18900 Data$=TRIM$(Pline1$&Pline2a$&Pline2b$&Pline3$) 18910 Name$="SPECTRUM__" 18920 GOTO Gosub_concat 18930 ! ----------------------------------------------------------------- 18940 P_linescan:! Sets up Dir$ for linescans 18950 Pline1$="10 Fl: READ Tp,Xmax,Ymin,Ymax,Smo,Ex,Con,Dt,F1,D1,Epass,Ret,Nor,Mag,Dirn,Ea,Eb" 18960 Pline2a$="20 DATA 2,"&VAL$(Xmax)&","&VAL$(Ymin)&","&VAL$(Ymax)&","&VAL$(Smo)&","&VAL$(Ex)&","&VAL$(Con)&","&VAL$(Dt)&","&VAL$(F1)&"," 18970 Pline2b$=VAL$(D1)&","&VAL$(Epass)&","&VAL$(Ret)&","&VAL$(Nor)&","&VAL$(Mag)&","&VAL$(Dirn)&","&VAL$(Ea)&","&VAL$(Eb) 18980 Pline2$=Pline2a$&Pline2b$ 18990 Pline3$="30 RETURN" 19000 Data$=TRIM$(Pline1$&Pline2a$&Pline2b$&Pline3$) 19010 Name$="LSCAN_____" 19020 GOTO Gosub_concat 19030 ! ---------------------------------------------------------------- 19040 P_image:! Sets up Dir$ for images 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" 19060 Pline2a$="20 DATA "&VAL$(Tp)&","&VAL$(M)&","&VAL$(N)&","&VAL$(Dt)&","&VAL$(F1)&","&VAL$(D1)&","&VAL$(Epass)&","&VAL$(Ret)&","&VAL$(Nor)&","&VAL$(Mag) 19070 Pline2b$=","&VAL$(Ea)&","&VAL$(Eb)&","&VAL$(Hist)&","&VAL$(Stepx)&","&VAL$(Stepy)&","&VAL$(Startx)&","&VAL$(Starty)&","&VAL$(Nsets) 19080 Pline2$=Pline2a$&Pline2b$ 19090 Pline3$=","&VAL$(No_subims)&"30 RETURN" 19100 Data$=TRIM$(Pline1$&Pline2a$&Pline2b$&Pline3$) 19110 Name$="IMAGE_____" 19120 GOTO Gosub_concat 19130 ! ----------------------------------------------------------------- 19140 Error_trap: ! 19150 BEEP 19160 IF ERRN=20 THEN GOTO 19250 19170 IF ERRN=64 THEN Full=1 19180 IF ERRN=64 THEN GOTO 19250 19190 IF ERRN=32 THEN Message$="PROBABLY ATTEMPTING TO SEND DECODED FILE-"&Fname$ 19200 IF ERRN=32 THEN GOSUB Message 19210 OFF ERROR 19220 Message$=ERRM$ 19230 GOSUB Message 19240 GOSUB Kjob 19250 RETURN 19260 ! ----------------------------------------------------------------- 19270 S_print:PRINTER IS 0 19280 PRINT "DEC file "&Fname$&" stored on HP disc as file "&Dfile$ 19290 S_print2:PRINT USING "K";Line1$ 19300 PRINT USING "K";Line2$ 19310 PRINT USING "K";Line3$ 19320 PRINTER IS 16 19330 RETURN 19340 F_print:PRINTER IS 0 19350 PRINT "HP file ";F1;" stored on DEC as file "&Fname$ 19360 GOTO S_print2 19370 ! -------------------------------------------------------------- 19380 Name:IF Tp=1 THEN Name$="SPECTRA___" 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_____" 19400 IF Tp=2 THEN Name$="LSCAN_____" 19410 IF Tp=5 THEN Name$="HISTOGRAM_" 19420 RETURN 19430 ! 19440 Fetch:! --------------------------------------------------------------- 19450 Fetched=1 19460 Line1$="" 19470 Line2$="" 19480 Line3$="" 19490 GOSUB Find_file 19500 ON Medium GOSUB Fetch_disc1,Fetch_tape1 19510 IF Fetch_check=1 THEN GOTO Fetch_return 19520 GOSUB Fetch_direct 19530 IF Fetch_check=1 THEN GOTO Fetch_return 19540 IF Medium=2 THEN GOSUB Fetch_tape2 19550 Fetch_return:RETURN 19560 ! 19570 Fetch_tape1:! --------------------------------------------------------- 19580 Fetch_check=0 19590 PRINT "CHANGE TAPES NOW, PRESS CONT TO GO ON" 19600 PAUSE 19610 MASS STORAGE IS ":T15" 19620 ASSIGN #3 TO "DIR:T15" 19630 ASSIGN #5 TO "Dnumbr:T15" 19640 READ #5;Dnumbr$ 19650 D1=VAL(Dnumbr$) 19660 READ #3,F1;Dir$ 19670 IF Dir$[2,3]="00" THEN GOSUB No_file 19680 Dim=LEN(Dir$) 19690 IF Dim=320 THEN Dir$=Dir$&RPT$(" ",1180) 19700 Fetch_tape1_ret:RETURN 19710 ! 19720 Fetch_disc1: ! -------------------------------------------------------- 19730 Fetch_check=0 19740 D1=0 19750 MASS STORAGE IS ":Q7" 19760 ON ERROR GOSUB No_file_hp 19770 FREAD "G"&VAL$(F1),Sig1(*) 19780 OFF ERROR 19790 IF Fetch_check=1 THEN GOTO Fetch_disc1_ret 19800 Size1=ROW(Sig1) 19810 Size=Sig1(Size1) 19820 REDIM Sig(1:Size) 19830 MAT Sig=Sig1 19840 L=Size1-Size-1 19850 ENTER Sig1(Size+1) USING "#,"&VAL$(2*L)&"A";Dir$ 19860 Fetch_disc1_ret:RETURN 19870 ! 19880 No_file_hp: Ee=ERRN 19890 Ll=ERRL 19900 OFF ERROR 19910 IF (Ee=56) AND (Ll=19770) THEN 19920 DISP "No such HP file" 19930 ELSE 19940 PRINT "UNEXPECTED ERROR" 19950 PRINT USING "6A,K,9A,K";"ERROR";Ee;"AT LINE ";Ll 19960 END IF 19970 Fetch_check=1 19980 RETURN 19990 Find_file:! --------------------------------------------------- 20000 Col=POS(Tf$,":") 20010 IF Col=0 THEN 20020 Tf$=Tf$&":Q" 20030 GOTO 20000 20040 END IF 20050 MASS STORAGE IS Tf$[Col] 20060 IF Tf$[Col+1;1]="Q" THEN Medium=1 20070 IF Tf$[Col+1;1]="T" THEN Medium=2 20080 F1=VAL(Tf$[2,Col-1]) 20090 RETURN 20100 Fetch_direct:! --------------------------------------------------- 20110 Fetch_check=0 20120 ASSIGN #4 TO "DUMMY1:Q7" 20130 P2=POS(Dir$," ") 20140 File$=Dir$[1,P2-1] 20150 Dir$=TRIM$(Dir$) 20160 P1=POS(Dir$,Cr$&Lf$) 20170 Name$=Dir$[P2+1,P2+10] 20180 Di$=Dir$[POS(Dir$,Cr$&Lf$)+2] 20190 R1=POS(Di$,Cr$&Lf$) 20200 Fetch_big:Line1$=Di$[1,R1-1] 20210 Di$[R1,R1+1]=" " 20220 R2=POS(Di$,Cr$&Lf$) 20230 Line2$=Di$[R1+2,R2-1] 20240 Di$[R2,R2+1]=" " 20250 R3=POS(Di$,Cr$&Lf$) 20260 IF R3=0 THEN 20360 20270 Line3$=Di$[R2+2,R3-1] 20280 Di$[R3,R3+1]=" " 20290 R4=POS(Di$,Cr$&Lf$) 20300 IF R4=0 THEN 20360 20310 Line4$=Di$[R3+2,R4-1] 20320 R5=POS(Di$,Cr$&Lf$&"10 ")-1 20330 IF R5