home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
hp9845.tar.gz
/
hp9845.tar
/
hp9845.bas
< prev
next >
Wrap
BASIC Source File
|
1988-08-16
|
70KB
|
2,155 lines
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) ! <CR> & <LF>
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, <CR><LF>
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<P THEN P=Pp
2360 END IF
2370 IF P=0 THEN
2380 F$=S$
2390 S$=""
2400 ELSE
2410 F$=S$[1,P-1]
2420 S$=S$[P,LEN(S$)]
2430 END IF
2440 RETURN ! RETURN F$=First 'word' S$=rest
2450 !
2460 ! EXIT ROUTINE
2470 ! ------------
2480 Exit:PRINT PAGE
2490 RESUME INTERACTIVE
2500 CDISCONNECT 2;HOLD ! ABORTIO 10
2510 PRINT "Kermit finished"
2520 END
2530 !
2540 ! CATALOGUE DISK
2550 ! --------------
2560 Dir:ON ERROR GOSUB Fserr
2570 Ff=0! Set error trap
2580 S$=TRIM$(S$)
2590 ! IF S$#"" THEN CAT S$ ELSE CAT ! Catalogue disk
2600 IF Ff<>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 Ll<Pp+2 THEN Volrem ! If no dest filename convert source
4250 S$=TRIM$(S$[Pp+2,Ll]) ! Get destination filename
4260 Pp=FNFsplit(S$,Q$,Ll)
4270 IF Pp=0 THEN Errfn ! Check for "filename"
4280 S$=TRIM$(S$[2,Pp])
4290 GOTO Chckfn ! Get destination filename
4300 !
4310 ! REMOVE VOLUME OR DRIVE No FROM FILE NAME
4320 ! ----------------------------------------
4330 Volrem: S$=Sf$ ! Get file name
4340 Pp=POS(S$,Dt$)
4350 IF Pp=0 THEN Pp=POS(S$,Cn$) ! "." - volume ":" - drive
4360 IF Pp>0 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 Ii<Ll THEN Ibuff$=I$[Ii+1,Ll]&Ibuff$ !If data in I$ replace in buffer
8320 IF Db=1 THEN CALL Awrite(Rrr,Rc,Rp$) ! display packet if debug on
8330 Cc$=FNCbyte$((Rp$[2,Jj-1]))! Calculate check byte | if wrong
8340 IF Cc$<>Rp$[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 Rr<Rlim THEN Send1 ! If retry < limit send again
8970 IF Rt$=Tm$ THEN
8980 Ff=1
8990 RETURN ! Timeout error
9000 END IF
9010 IF Rt$=Nk$ THEN ! NAK error
9020 Ff=2
9030 ELSE
9040 Ff=3
9050 END IF
9060 RETURN
9070 !
9080 ! CONSTRUCT PACKET
9090 ! ----------------
9100 C_pack: Op$=FNChar$(BINAND(Nn,63))&T$&Od$ ! Add seq & type to data
9110 Op$=FNChar$(LEN(Op$)+1)&Op$ ! Add length to data
9120 Op$=Mk$&Op$&FNCbyte$(Op$) ! Add mark & check byte
9130 IF Snpad>0 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$<Sp$ THEN
11790 Db$=Db$&Sqctl$
11800 Kk$=FNCtl$(Kk$) ! If ctRl prefix
11810 END IF
11820 IF Kk$=Sqctl$ THEN Db$=Db$&Kk$ ! If prefix prefix
11830 Db$=Db$&Kk$
11840 NEXT Ii
11850 GOTO 11380 ! Add char to buffer
11860 IF Sc=0 THEN
11870 Ff=23
11880 RETURN ! If no conversion - error
11890 END IF
11900 SELECT Data_type
11910 CASE 1
11920 READ #1,S
11930 CASE 2
11940 CALL Encode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Sig(*),Sigj,Line_no,Rmaxl,Span,Sig0)
11950 END SELECT
11960 S$=VAL$(S) ! Convert no to string
11970 Db$=Db$&Sp$&S$
11980 Kk=Kk+LEN(S$)+1
11990 GOTO 11380 ! Add no to buffer
12000 OFF ERROR ! Stop error trap
12010 IF Ll<=Maxl THEN
12020 Od$=Db$
12030 Db$=""
12040 RETURN ! If amount<max output
12050 END IF
12060 S=Maxl ! Get split position
12070 IF Db$[S,S]=Sqctl$ THEN
12080 S=S-1
12090 GOTO 12070 ! If prefix move split
12100 END IF
12110 Od$=Db$[1,S]
12120 Db$=Db$[S+1,Ll] ! Split data save rest
12130 RETURN
12140 OFF ERROR
12150 IF (ERRN=59) OR (ERRN=60) THEN 11440! End of file
12160 IF ERRN=65 THEN
12170 Ff=23
12180 RETURN ! Data type error
12190 END IF
12200 GOTO Fserr ! Goto error routine
12210 !
12220 ! CREATE & OPEN FILE FOR WRITING
12230 ! ------------------------------
12240 Open_write: Ff=0 ! Set error flag
12250 IF Df$<>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<L THEN 13990 ! Find next option
14100 Jj=0 ! If no more illegal option
14110 RETURN Jj
14120 FNEND
14130 !
14140 ! FUNCTION TO CONVERT STRING TO NO
14150 ! --------------------------------
14160 Pval:DEF FNPval(Cc$,I$,Iv$,INTEGER Oo,Pp)
14170 IF Cc$<>"?" 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<L THEN 14490 ! Get next option
14620 RETURN "" ! If end of list RETURN null
14630 FNEND
14640 ! ******************************************************** !
14650 ! Subroutine AWRITE to do full screen handling ***** !
14660 ! TO SIMULATE THE CALL Awrite UTILITY OF THE HP86/HP87
14670 !
14680 ! ******************************************************** !
14690 Awrite: SUB Awrite(INTEGER A,B,K$)
14700 S$="&a"&VAL$(A)&"r"&VAL$(B)&"C"
14710 PRINT USING "#,K";CHR$(27)&S$
14720 PRINT K$
14730 SUBEND
14740 ! ****************************************************
14750 !
14760 ! SUBROUTINE BWRITE TO POSITION THE CURSOR.
14770 !
14780 ! ****************************************************
14790 Bwrite: SUB Bwrite(INTEGER A,B)
14800 S$="&a"&VAL$(A)&"r"&VAL$(B)&"C"
14810 PRINT USING "#,K";CHR$(27)&S$
14820 SUBEND
14830 !
14840 ! CALCULATE CHECK BYTE
14850 ! --------------------
14860 Cbyte:DEF FNCbyte$(S$)
14870 INTEGER Tt1
14880 Tt=0
14890 Ll=LEN(S$)
14900 FOR Ii=1 TO Ll
14910 Tt=Tt+NUM(S$[Ii,Ii])
14920 NEXT Ii ! sum S$
14930 Tt1=BINAND(Tt+BINAND(Tt,192)/64,63) ! Fold bits 7 & 8
14940 Tt1$=FNChar$(Tt1)
14950 Char:DEF FNChar$(INTEGER Nn)=CHR$(Nn+32) ! Character = no + 32
14960 RETURN Tt1$
14970 FNEND
14980 !
14990 Kb:DEF FNKb$(Kk)
15000 Kb$=VAL$(INT(Kk/102.4)/10)&"k "
15010 RETURN Kb$
15020 FNEND
15030 Decode:SUB Decode(S$,File$,Title$,Line1$,Line2$,Line3$,Info$(*),Left$,INTEGER Sig(*),Sigj,Line_no,Pp,Inf,Sig0)
15040 INTEGER Span2
15050 DIM Line$[256]
15060 Lf=0
15070 ON Line_no GOTO 15080,15140,15200,15250,15300,15350,15410
15080 CALL Linefill(S$,Line$,Left$,Lf)
15090 IF NOT Lf THEN 15440
15100 Line_no=2
15110 File$=Line$[1,Lf-1]
15120 Line$=""
15130 Lf=0
15140 CALL Linefill(S$,Line$,Left$,Lf)
15150 IF NOT Lf THEN 15440
15160 Title$=Line$[1,Lf-1]
15170 Line_no=3
15180 Line$=""
15190 Lf=0
15200 CALL Linefill(S$,Line$,Left$,Lf)
15210 IF NOT Lf THEN 15440
15220 Line1$=Line$[1,Lf-1]
15230 Line$=""
15240 Line_no=4
15250 CALL Linefill(S$,Line$,Left$,Lf)
15260 IF NOT Lf THEN 15440
15270 Line2$=Line$[1,Lf-1]
15280 Line$=""
15290 Line_no=5
15300 CALL Linefill(S$,Line$,Left$,Lf)
15310 IF NOT Lf THEN 15440
15320 Line3$=Line$[1,Lf-1]
15330 Line$=""
15340 Line_no=6
15350 CALL Infofill(S$,Info$(*),Inf,Left$)
15360 IF Inf>=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 (S<Lb1) OR (S>Ub1) THEN 15850
15830 Cn$=CHR$(ABS(S)+Bias)
15840 GOTO 15920
15850 IF (S<Lb2) OR (S>Ub2) 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 L<Nc THEN 16860
16690 SELECT Nc
16700 CASE 1
16710 S=C1
16720 S$=S$[P+2]
16730 CASE 2
16740 S=A2*C1+NUM(S$[P+2])-Bias
16750 S$=S$[P+3]
16760 CASE 3
16770 S=A3*C1+A2*(NUM(S$[P+2])-Bias)+NUM(S$[P+3])-Bias
16780 S$=S$[P+4]
16790 END SELECT
16800 IF T<>C1 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<R4 THEN R5=R4+2
20340 Line5$=Di$[R4+2,R5]
20350 Di$=Dir$[POS(Dir$,Cr$&Lf$&"10 "),LEN(Dir$)]
20360 FOR I=1 TO 5
20370 P=POS(Di$,VAL$(I)&"0 ")
20380 Lstart=P
20390 IF P=0 THEN 20450
20400 P=POS(Di$,VAL$(I+1)&"0 ")
20410 Lend=P-1
20420 IF P=0 THEN Lend=LEN(Di$)
20430 PRINT #4,I;Di$[Lstart,Lend]
20440 NEXT I
20450 LINK "DUMMY1:Q",21370,Gosub_fl
20460 Gosub_fl: GOSUB Fl
20470 FOR I=1 TO 50
20480 Info$(I)="0.00"
20490 NEXT I
20500 IF Tp=1 THEN Size=Rnge
20510 IF Tp=2 THEN Size=Xmax
20520 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) THEN Size=M*N
20530 IF Tp=1 THEN Info_array
20540 IF Tp=2 THEN Info_array1
20550 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) THEN Info_array2
20560 PRINT TAB(10),"File type not recognised"
20570 Message$="File type not recognised"
20580 GOSUB Message
20590 GOSUB Kjob
20600 Fetch_dir_redim: REDIM Sig1(1:Size),Sig(1:Size)
20610 Fetch_dir_ret:RETURN
20620 !
20630 Fetch_tape2:! ---------------------------------------------------------
20640 MASS STORAGE IS ":T15"
20650 ASSIGN #2 TO File$
20660 BUFFER #2
20670 READ #2;Sig(*)
20680 ASSIGN * TO #2
20690 MASS STORAGE IS ":Q7"
20700 REWIND ":T15"
20710 Fetch_tape2_ret:RETURN
20720 !
20730 Store:! ---------------------------------------------------------------
20740 IF Tp=1 THEN Size=Rnge
20750 IF Tp=2 THEN Size=Xmax
20760 IF (Tp=3) OR (Tp=4) OR (Tp=6) OR (Tp=7) OR (Tp=8) OR (Tp=9) THEN Size=M*N
20770 EXIT GRAPHICS
20780 GOSUB Store_disc
20790 Wh=1
20800 PRINT "Data stored as file ";Dfile$
20810 GOSUB S_print
20820 Store_ret:RETURN
20830 ! --------------------------------------------------------------
20840 Concat:Notes$=TRIM$(Line1$&Line2$&Line3$&Line4$&Line5$)
20850 Dir$=RPT$(" ",7)&Name$&Cr$&Lf$&Notes$&Data$
20860 L=LEN(Dir$)
20870 Dir_ok:Dir$=TRIM$(Dir$)
20880 Concat_ret:RETURN
20890 !
20900 Store_disc: ! --------------------------------------------------------
20910 REDIM Sig1(1:Size)
20920 MAT Sig1=Sig
20930 Dz=0
20940 GOSUB Slot_disc
20950 Dim=1500
20960 IF Tp=1 THEN P_spectrum
20970 IF Tp=2 THEN P_linescan
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
20990 Gosub_concat: GOSUB Concat
21000 GOSUB Entry_disc
21010 GOSUB Redim2
21020 OUTPUT Sig1(Size+1) USING "#,"&VAL$(2*Ldir)&"A,W";Dir$,Size
21030 FCREATE Dfile$&":Q7",INT(Rnge2/128)+INT(Rnge2/32768)+3
21040 LINK "GWRITE:Q7",21370,Store_disc_call
21050 Store_disc_call:CALL Gwrite(Rnge2,Slot,Sig1(*))
21060 GOSUB Update
21070 Store_end:DISP
21080 Store_return:RETURN
21090 Update:! -----------------------------------------------------------------
21100 ASSIGN #3 TO "GNUMBR:Q7"
21110 PRINT #3;Slot
21120 ASSIGN * TO #3
21130 Update_return:RETURN
21140 !
21150 Slot_disc: ! ----------------------------------------------------------
21160 ASSIGN #3 TO "GNUMBR:Q7"
21170 READ #3;Gnumbr
21180 ASSIGN * TO #3
21190 Slot_disc_found:Slot=Gnumbr+1
21200 Slot_disc_ret:RETURN
21210 !
21220 Entry_disc: ! ----------------------------------------------------------
21230 Dfile$="G"&VAL$(Slot)
21240 Di$=Dfile$&" "&Dir$
21250 Dirlen=LEN(Di$)
21260 Ldir=(Dirlen+1) DIV 2
21270 Dir$=Di$&RPT$(" ",Ldir*2-Dirlen)
21280 Entry_disc_ret:RETURN
21290 !
21300 Redim2:! ------------------------------------------------------------------
21310 Rnge2=Size+Ldir+1
21320 REDIM Sig(1:Size)
21330 REDIM Sig1(1:Rnge2)
21340 Redim2_end:RETURN
21350 ! -----------------------------------------------------------------------
21360 !
21370 Fl:READ Tp,M,N,Dt,F1,D1,Epass,Ret,Nor,Mag,E,Stepx,Stepy,Startx,Starty,Nsets,No_subims
21380 DATA 4,128,128,10,2916,0,50,0,0,500,0,4,4,1,1,2,1
21390 RETURN