100 '   SORT-BLK.BAS   by   Bob Noble, Philadelphia IBM PC Users Club
110 '                       Submitted 8-21-82.
120 '
130 '   This program must be altered for the programmer's specific application.
140 '   The data file to be operated on must be a fixed-field-length, random-
150 '   access type, and the record size must be a multiple of 128 bytes. If
160 '   not specified in the OPEN statement, the default is 128.
170 '
180 '   The file used in this version is called ARTICLES. It has 61 fields tot-
190 '   aling 363 bytes (e.g. the record size is 128*3 = 384). Note that when
200 '   more fields are needed than can fit in a single 256 byte FIELD state-
210 '   ment, dummy variables with parameters <= 256 must be used at the begin-
220 '   ing of each sucessive FIELD statement.
230 '
240 '   The file is blocked so that each group of 16 records contains 13 act-
250 '   ual records followed by an overflow space of 3 null records. The first
260 '   2 bytes of a null record are "@@".
270 '
280 '   The key being sorted is the "Headline" field AF$. The arrays are loaded
290 '   with the first 32 characters of the key field in each actual record,
300 '   nulls are skipped. The sort used is a popular binary one. A new sorted
310 '   and blocked file is created. The original is killed and the new file
320 '   is renamed to the original.
330 '
340 '   This program would be used as part of a system. A data entry program
350 '   would put new records in the proper overflow space via an alphabetic
360 '   search. Every time an overflow space becomes full, the file must be
370 '   sorted and reblocked.
380 '
390 '   Significant improvements in disk space utilization, and time may be
400 '   achieved by creating a separate index file consisting of the first
410 '   32 bytes of each key and a pointer to the record in which it resides.
420 '   Then the data file itself would not have to be blocked or sorted.
430 '
440 '   I am intent on learning all ISAM, and other useful data management
450 '   techniques. I will continue to submit what I develope as long as
460 '   there is an interest. Please contact me with questions or help.
470 '           (215) 329-4205          5431 North 12th Street
480 '                                   Philadelphia, PA 19141
490 '
500 CLEAR: CLS: OPEN "R", 1, "B:ARTICLES", 384
510 FIELD 1, 155 AS AF$, 5 AS BF$, 8 AS CF$, 45 AS DF$, 5 AS LLF$, 11 AS EF$,                1 AS FF$, 1 AS GF$, 1 AS HF$, 1 AS IIF$, 1 AS JF$, 1 AS KF$,                    1 AS LF$, 1 AS MF$, 1 AS NF$, 1 AS OF$, 1 AS PF$, 1 AS CQF$
520 FIELD 1, 241 AS ZZ1$, 1 AS RF$, 1 AS SF$, 1 AS TF$, 1 AS UF$, 1 AS VF$,                  1 AS WF$, 1 AS XF$, 1 AS YF$, 1 AS ZF$, 1 AS AAF$, 1 AS ABF$,                   1 AS ACF$, 1 AS ADF$, 1 AS AEF$, 1 AS CAFF$, 1 AS AGF$, 1 AS AHF$
530 FIELD 1, 129 AS ZZ2$, 129 AS ZZ3$, 1 AS AIF$, 1 AS AJF$, 1 AS AKF$,                      1 AS ALF$, 1 AS AMF$, 1 AS ANF$, 1 AS AOF$, 1 AS APF$, 1 AS AQF$,               1 AS ARF$, 1 AS ASF$, 1 AS ATF$, 1 AS AUF$, 1 AS AVF$, 1 AS AWF$
540 FIELD 1, 137 AS ZZ4$, 136 AS ZZ5$, 1 AS AXF$, 1 AS AYF$, 1 AS AZF$,                      1 AS BAF$, 1 AS BBF$, 1 AS BCF$, 1 AS BDF$, 1 AS BEF$, 1 AS CBFF$,              1 AS BGF$, 75 AS BHF$
550 '
560 PRINT "ARTICLES *** SORT AND BLOCK ROUTINE"
570 PRINT: PRINT "PRESS ANY KEY TO START SORT"
580 Q$ = INKEY$: IF Q$="" THEN 580
590 '
600 '       ***************************************
610 '       ************  Load Arrays  ************
620 '       ***************************************
630 '
640 PRINT: PRINT "AS NUMBERS APPROACH 0, TASKS NEAR END" TAB(66) "TIME"
650 PRINT: PRINT "LOADING ARRAYS FROM ORIGINAL FILE ------------------------>"
660 K = LOF(1)/384: V=K: I%=0: T=0: TIME$="00:00:00"
670 DIM ZZ$(K), R(K)
680 FOR X=1 TO K
690   V=V-1: LOCATE 7,60: PRINT V
700   I%=I%+1: IF I%=K+1 THEN 740 ELSE GET 1,I%
710     IF LEFT$(AF$,2)="@@" THEN 700
720   T=T+1: ZZ$(T) = LEFT$(AF$,32): R(T)=I%
730 NEXT
740 TI1$=TIME$: LOCATE 7,64: PRINT TI1$
750 '
760 '       ***************************************
770 '       ************  Shell Sort  *************
780 '       ***************************************
790 '
800 CLOSE
810 V=0: LOCATE 7,60: PRINT V: PRINT: PRINT "SORT STARTED --------------------------------------------->": M=T: TIME$="00:00:00"
820 M=INT(M/2): LOCATE 9,60: PRINT M: IF M=0 THEN 930 ELSE P=T-M: J=1
830   N=J
840     L=N+M
850     GOSUB 1210 ' *** Determine A1$ and B1$
860       IF ASC(A1$) > ASC(B1$) THEN SWAP ZZ$(N),ZZ$(L): SWAP R(N),R(L):                   N=N-M: IF N>=1 THEN 840
870 J=J+1: IF J>P THEN 820 ELSE 830
880 '
890 '       ****************************************
900 '       *  Create new sorted and blocked file  *
910 '       ****************************************
920 '
930 TI2$=TIME$: LOCATE 9,64: PRINT TI2$
940 LOCATE 11,1: PRINT "SORT ENDED - NOW CREATING NEW SORTED AND BLOCKED FILE ---->"
950 I%=0: D=14: C=T: TIME$="00:00:00": GOSUB 1520 ' *** Open Files
960 FOR Y=1 TO T: C=C-1: LOCATE 11,60: PRINT C
970   I%=I%+1: IF I%=D THEN D=D+16: GOSUB 1680 ' ****** Skip 3 records
980   GET 1,R(Y): GOSUB 1340 ' ************************* LSET variables
990   PUT 2,I%
1000 NEXT Y
1010 TI3$=TIME$: LOCATE 11,64: PRINT TI3$
1020 '
1030 GOSUB 1780 ' ***** Determine Total Time
1040 '
1050 PRINT: PRINT "TOTAL TIME ="; TH; "HOURS"; TM; "MINUTES"; TS; "SECONDS"
1060 '
1070 '       ***************************************
1080 '       ***************  End  *****************
1090 '       ***************************************
1100 '
1110 CLOSE: KILL "B:ARTICLES": NAME "B:ARTICLE" AS "B:ARTICLES"
1120 '
1130 PRINT: PRINT "PROGRAM OVER - PRESS ANY KEY TO RETURN TO MAIN MENU"
1140 Q$=INKEY$: IF Q$="" THEN 1140
1150 RUN "ART-MAIN.BAS"
1160 '
1170 '     *****************************************
1180 '     *  Subroutine to determine A1$ and B1$  *
1190 '     *****************************************
1200 '
1210 H=1: S=1
1220 A1$ = MID$(ZZ$(N),H,1): B1$ = MID$(ZZ$(L),S,1)
1230   IF MID$(ZZ$(N),H,2)="  " THEN A1$="AAAAAAAA"
1240   IF MID$(ZZ$(L),S,2)="  " THEN B1$="AAAAAAAA"
1250   IF ASC(A1$)>64 AND ASC(A1$)<91 THEN 1260 ELSE H=H+1: GOTO 1220
1260   IF ASC(B1$)>64 AND ASC(B1$)<91 THEN 1270 ELSE S=S+1: GOTO 1220
1270   IF ASC(A1$)=ASC(B1$) THEN H=H+1: S=S+1: GOTO 1220
1280 RETURN
1290 '
1300 '      ****************************************
1310 '      ****  Subroutine to LSET variables  ****
1320 '      ****************************************
1330 '
1340 LSET AF$=A$:LSET BF$=B$:LSET CF$=C$:LSET DF$=D$:LSET LLF$=LL$:LSET EF$=E$
1350 LSET FF$=F$:LSET GF$=G$:LSET HF$=H$:LSET IIF$=II$:LSET JF$=J$:LSET KF$=K$
1360 LSET LF$=L$:LSET MF$=M$:LSET NF$=N$:LSET OF$=O$:LSET PF$=P$:LSET CQF$=CQ$
1370 LSET RF$=R$:LSET SF$=S$:LSET TF$=T$:LSET UF$=U$:LSET VF$=V$:LSET WF$=W$
1380 LSET XF$=X$:LSET YF$=Y$:LSET ZF$=Z$:LSET AAF$=AA$:LSET ABF$=AB$
1390 LSET ACF$=AC$:LSET ADF$=AD$:LSET AEF$=AE$:LSET CAFF$=CAF$:LSET AGF$=AG$
1400 LSET AHF$=AH$:LSET AIF$=AI$:LSET AJF$=AJ$:LSET AKF$=AK$:LSET ALF$=AL$
1410 LSET AMF$=AM$:LSET ANF$=AN$:LSET AOF$=AO$:LSET APF$=AP$:LSET AQF$=AQ$
1420 LSET ARF$=AR$:LSET ASF$=AS$:LSET ATF$=AT$:LSET AUF$=AU$:LSET AVF$=AV$
1430 LSET AWF$=AW$:LSET AXF$=AX$:LSET AYF$=AY$:LSET AZF$=AZ$:LSET BAF$=BA$
1440 LSET BBF$=BB$:LSET BCF$=BC$:LSET BDF$=BD$:LSET BEF$=BE$:LSET CBFF$=CBF$
1450 LSET BGF$=BG$:LSET BHF$=BH$
1460 RETURN
1470 '
1480 '       ****************************************
1490 '       ******  Subroutine to open files  ******
1500 '       ****************************************
1510 '
1520 OPEN "R", 1, "B:ARTICLES", 384
1530 FIELD 1, 155 AS A$, 5 AS B$, 8 AS C$, 45 AS D$, 5 AS LL$, 11 AS E$,                      1 AS F$, 1 AS G$, 1 AS H$, 1 AS II$, 1 AS J$, 1 AS K$, 1 AS L$,                 1 AS M$, 1 AS N$, 1 AS O$, 1 AS P$, 1 AS CQ$
1540 FIELD 1, 241 AS ZZ1$, 1 AS R$, 1 AS S$, 1 AS T$, 1 AS U$, 1 AS V$, 1 AS W$,              1 AS X$, 1 AS Y$, 1 AS Z$, 1 AS AA$, 1 AS AB$, 1 AS AC$, 1 AS AD$,              1 AS AE$, 1 AS CAF$, 1 AS AG$, 1 AS AH$
1550 FIELD 1, 129 AS ZZ2$, 129 AS ZZ3$, 1 AS AI$, 1 AS AJ$, 1 AS AK$, 1 AS AL$,               1 AS AM$, 1 AS AN$, 1 AS AO$, 1 AS AP$, 1 AS AQ$, 1 AS AR$,                     1 AS AS$, 1 AS AT$, 1 AS AU$, 1 AS AV$, 1 AS AW$
1560 FIELD 1, 137 AS ZZ4$, 136 AS ZZ5$, 1 AS AX$, 1 AS AY$, 1 AS AZ$, 1 AS BS$,               1 AS BB$, 1 AS BC$, 1 AS BD$, 1 AS BE$, 1 AS CBF$, 1 AS BGF$,                   75 AS BHF$
1570 OPEN "R", 2, "B:ARTICLE", 384
1580 FIELD 2, 155 AS AF$, 5 AS BF$, 8 AS CF$, 45 AS DF$, 5 AS LLF$, 11 AS EF$,                1 AS FF$, 1 AS GF$, 1 AS HF$, 1 AS IIF$, 1 AS JF$, 1 AS KF$,                    1 AS LF$, 1 AS MF$, 1 AS NF$, 1 AS OF$, 1 AS PF$, 1 AS CQF$
1590 FIELD 2, 241 AS ZZ1$, 1 AS RF$, 1 AS SF$, 1 AS TF$, 1 AS UF$, 1 AS VF$,                  1 AS WF$, 1 AS XF$, 1 AS YF$, 1 AS ZF$, 1 AS AAF$, 1 AS ABF$,                   1 AS ACF$, 1 AS ADF$, 1 AS AEF$, 1 AS CAFF$, 1 AS AGF$, 1 AS AHF$
1600 FIELD 2, 129 AS ZZ2$, 129 AS ZZ3$, 1 AS AIF$, 1 AS AJF$, 1 AS AKF$,                      1 AS ALF$, 1 AS AMF$, 1 AS ANF$, 1 AS AOF$, 1 AS APF$, 1 AS AQF$,               1 AS ARF$, 1 AS ASF$, 1 AS ATF$, 1 AS AUF$, 1 AS AVF$, 1 AS AWF$
1610 FIELD 2, 137 AS ZZ4$, 136 AS ZZ5$, 1 AS AXF$, 1 AS AYF$, 1 AS AZF$,                      1 AS BAF$, 1 AS BBF$, 1 AS BCF$, 1 AS BDF$, 1 AS BEF$, 1 AS CBFF$,              1 AS BGF$, 75 AS BHF$
1620 RETURN
1630 '
1640 '          **************************************
1650 '          ***  Subroutine to Skip 3 Records  ***
1660 '          **************************************
1670 '
1680 FIELD 1, 2 AS XYZ$: FIELD 2, 2 AS XYZF$
1690 FOR X=1 TO 3
1700   GET 1,1: XYZ$="@@": LSET XYZF$=XYZ$: PUT 2,I%: I%=I%+1
1710 NEXT X
1720 FIELD 1, 155 AS A$: FIELD 2, 155 AS AF$: RETURN
1730 '
1740 '          ********************************************
1750 '          ***  Subroutine to Determine Total Time  ***
1760 '          ********************************************
1770 '
1780 H1=VAL(LEFT$(TI1$,2)): M1=VAL(MID$(TI1$,4,2)): S1=VAL(RIGHT$(TI1$,2))
1790 H2=VAL(LEFT$(TI2$,2)): M2=VAL(MID$(TI2$,4,2)): S2=VAL(RIGHT$(TI2$,2))
1800 H3=VAL(LEFT$(TI3$,2)): M3=VAL(MID$(TI3$,4,2)): S3=VAL(RIGHT$(TI3$,2))
1810 TSEC = (3600*(H1+H2+H3)) + (60*(M1+M2+M3)) + S1 + S2 + S3
1820 TH=INT(TSEC/3600):TM=INT((TSEC-TH*3600)/60):TS=TSEC-(TH*3600)-(TM*60)
1830 RETURN