'HEAD' GENERAL UTILITIES C EDIT DATE 18JAN79 21:27 C SOURCE FILE UTILSFTM.FS C AUTHOR F. T. MICKEYM C CLUSTER 28 'OUTFILE' GCHAR.FR C SUBROUTINE GCHAR (BUFFER, CHARACTER INDEX) C C RETURNS AS INTEGER FUNCTION VALUE THE CHARACTER POINTED C TO BY CHARACTER INDEX, WITH THE LEFT-HAND CHARACTER OF C BUFFER (1) DEFINED AS CHARACTER 1. CHARACTERS ARE RIGHT ADJUS- C TED, WITH A LEADING NULL BYTE. C C *************** C PDP-11/70 ONLY* C *************** INTEGER FUNCTION GCHAR (BUF, INDEX) INTEGER BUF (66), I, INDEX I = ISHFT (INDEX+1, -1) 'IF' (IAND (INDEX, 1) .EQ. 0) GCHAR = ISHFT (BUF (I), -8) 'ELSE' GCHAR = IAND (BUF (I), 255) 'ENDIF' RETURN END 'OUTFILE' PCHAR.FR C SUBROUTINE PCHAR (BUFFER, CHARACTER INDEX, CHARACTER) C C PLACES CHARACTER INTO BUFFER AT POSITION POINTED TO BY C CHARACTER POINTER. C C *************** C PDP-11/70 ONLY* C *************** SUBROUTINE PCHAR (BUF, INDEX, CHAR) INTEGER BUF (66), INDEX, CHAR INTEGER I I = ISHFT (INDEX+1, -1) 'IF' (IAND (INDEX, 1) .EQ. 0) BUF (I) = IAND (BUF (I), 255) + ISHFT (CHAR, 8) 'ELSE' BUF (I) = IAND (BUF (I), -256) + IAND (CHAR, 255) 'ENDIF' RETURN END 'OUTFILE' SET.FR C SUBROUTINE SET (VALUE, BUFFER, COUNT) C C SETS 'COUNT' WORDS FROM START OF BUFFER TO VALUE C SUBROUTINE SET (VALUE, BUFFER, COUNT) INTEGER VALUE, COUNT, BUFFER (COUNT), I 'DOLOOP' I = 1, COUNT BUFFER (I) = VALUE 'END' RETURN END 'OUTFILE' MOVE.FR C SUBROUTINE MOVE (FROM, TO, COUNT) C C MOVES 'COUNT' WORDS FROM 'FROM' TO 'TO' C SUBROUTINE MOVE (FROMB, TOB, COUNT) INTEGER COUNT, FROMB (COUNT), TOB (COUNT), I 'DOLOOP' I = 1, COUNT TOB (I) = FROMB (I) 'END' RETURN END 'HEAD' OUTPUT FORMATTING ROUTINES 'OUTFILE' ESPJHP.FR C NAME ESP C PURPOSE CONVERT SINGLE PRECISION NUMBER TO ASCII C (SIGNED DECIMAL, RIGHT ADJUST) C (UNUSED FIELD POSITIONS ARE NOT MODIFIED) C CALL CALL ESP (WORD, BUF, LEFT, RIGHT) C WORD DATA TO BE CONVERTED C BUF OUTPUT BUFFER C LEFT LEFTMOST CHARACTER POSITION (1-N) C RIGHT RIGHT CHARACTER POSITION C ERRORS NO ERROR INDICATIONS C RETURN IF: C CONVERSION COMPLETE C FIELD FULL SUBROUTINE ESP (WORD, BUF, LEFT, RIGHT) INTEGER WORD, BUF, LEFT, RIGHT INTEGER CHAR, MFLAG, WORK, XMINUS, XZERO, COL DATA XMINUS / 45 / DATA XZERO / 48 / C INITIALIZE 'IF' (WORD .LT. 0) WORK = - WORD MFLAG = 1 'ELSE' WORK = WORD MFLAG = 0 'ENDIF' COL = RIGHT 'DO' 'WHILE' (COL .GE. LEFT) CHAR = MOD (WORK, 10) + XZERO WORK = WORK / 10 CALL PCHAR (BUF, COL, CHAR) COL = COL - 1 'IF' (WORK .LE. 0) 'BREAK' 'ENDIF' 'END' IF (MFLAG .NE. 0 .AND. COL .GE. LEFT) ^ CALL PCHAR (BUF, COL, XMINUS) RETURN END 'OUTFILE' ESTJHP.FR C NAME EST C PURPOSE MOVE STRING INTO BUFFER FIELD C CALL CALL EST (STR, BUF, LEFT, RIGHT) C STR INPUT STRING C BUF OUTPUT BUFFER C LEFT LEFT CHARACTER POSITION IN BUF (1-N) C RIGHT RIGHTMOST CHARACTER POSITION C ERROR NO ERROR INDICATIONS SUBROUTINE EST (STR, BUF, LEFT, RIGHT) INTEGER STR, BUF, LEFT, RIGHT INTEGER GETX, PUTX INTEGER GCHAR GETX = 1 PUTX = LEFT 'DO' 'WHILE' (PUTX .LE. RIGHT) CALL PCHAR (BUF, PUTX, GCHAR (STR, GETX)) GETX = GETX + 1 PUTX = PUTX + 1 'END' RETURN END 'OUTFILE' EHXJHP.FR C NAME EHX C PURPOSE CONVERT A WORD TO ASCII IN HEX FORMAT C (RIGHT ADJUSTED, ZERO FILLED) C CALL CALL EHX (WORD, BUF, LEFT, RIGHT) C WORD INPUT DATA C BUF BUFFER TO RECEIVE DATA C LEFT LEFT CHARACTER POSITION IN BUF (1-N) C RIGHT RIGHTMOST CHARACTER POSITION C ERRORS NO ERROR INDICATIONS C RETURN IF: C FIELD FULL SUBROUTINE EHX (WORD, BUF, LEFT, RIGHT) INTEGER WORD, BUF, LEFT, RIGHT INTEGER WORK, CHAR, COL, XZERO, XLETA, MASK, BIAS DATA XZERO / 48 / DATA XLETA / 55 / DATA MASK / 15 / COL = RIGHT WORK = WORD 'DO' 'WHILE' (COL .GE. LEFT) CHAR = IAND (WORK, MASK) 'IF' (CHAR .GE. 10) BIAS = XLETA 'ELSE' BIAS = XZERO 'ENDIF' CALL PCHAR (BUF, COL, CHAR + BIAS) WORK = ISHFT (WORK, -4) COL = COL - 1 'END' RETURN END 'HEAD' SHELL SORT 'OUTFILE' SORTAJH.FR SUBROUTINE SORT (LIST, COUNT, ARRAY, COMP) C C SHELL SORT, DESCRIBED AS "PROGRAM C" IN "AN EMPIRICAL STUDY C OF MINIMAL STORAGE SORTING" BY T. N. HUBBARD, CACM VOL 5, C NO 5, (MAY 1963) PP. 206-216 C C INPUT: C LIST = ARRAY OF INDEXES TO ITEMS IN 'ARRAY' C COUNT = NUMBER OF ITEMS TO BE SORTED C ARRAY = ITEMS TO BE SORTED C COMP = FUNCTION TO COMPARE ITEMS FOR SORTING C C OUTPUT: C LIST = SORTED INDEXES TO 'ARRAY' C INTEGER COUNT, LIST (COUNT), ARRAY (COUNT) INTEGER CT, STEP, COMP INTEGER I, J, K, L, M, N 'EJECT' K = COUNT IF (K .LE. 1) RETURN CT = K STEP = 1 'DO' K = ISHFT (K, -1) 'WHILE' (K .NE. 0) STEP = STEP + STEP 'END' STEP = STEP - 1 'DO' K = 1 'DO' L = K I = L + STEP J = I N = LIST (I) 'DO' M = LIST (L) 'IF' (COMP (ARRAY (N), ARRAY (M)) .LT. 0) LIST (J) = M J = L L = J - STEP 'IF' (L .GE. 1) 'END' 'ENDIF' 'ENDIF' LIST (J) = N K = K + 1 'WHILE' (K + STEP .LE. CT) 'END' STEP = ISHFT (STEP, -1) 'WHILE' (STEP .NE. 0) 'END' RETURN END 'HEAD' RSX INTERFACE ROUTINES 'OUTFILE' RSXINTFCE.FR SUBROUTINE OPENF (CHAN, FILE, ERROR) C OPEN AN EXISTING FILE INTEGER CHAN, FILE (15), ERROR OPEN (UNIT = CHAN, NAME = FILE, SHARED, ^ TYPE = 'OLD', ERR = 100) ERROR = 1 RETURN 100 ERROR = -1 RETURN END SUBROUTINE OPENN (CHAN, FILE, ERROR) C OPEN A NEW OUTPUT FILE INTEGER CHAN, FILE (15), ERROR OPEN (UNIT = CHAN, NAME = FILE, TYPE = 'NEW', ERR = 100) ERROR = 1 RETURN 100 ERROR = -1 RETURN END 'EJECT' SUBROUTINE CLOSF (CHAN, ERROR) C CLOSE AN OPEN FILE, DON'T DELETE IT INTEGER CHAN, ERROR CLOSE (UNIT = CHAN, ERR = 100) ERROR = 1 RETURN 100 ERROR = -1 RETURN END SUBROUTINE DELETE (CHAN, FILE) C DELETE A FILE INTEGER CHAN, FILE (15) CLOSE (UNIT = CHAN, DISP = 'DELETE') RETURN END SUBROUTINE REW (CHAN, FILE) C REWIND A FILE INTEGER CHAN, FILE (15) REWIND CHAN RETURN END 'EJECT' SUBROUTINE RDLIN (CHAN, BUFFER, MAX, ERROR) C READ AN ASCII LINE (MAX CHARACTERS) INTEGER CHAN, BUFFER (40), MAX, ERROR INTEGER WORDS WORDS = (MAX + 1)/2 READ (CHAN, 1000, END = 100) (BUFFER (I), I = 1, WORDS) ERROR = 1 RETURN 100 ERROR = 9 RETURN 1000 FORMAT (40A2) END SUBROUTINE WRLIN (CHAN, BUFFER, CHARS) C WRITE ASCII CHARACTERS INTEGER CHAN, BUFFER (66), CHARS INTEGER WORDS WORDS = (CHARS + 1)/2 WRITE (CHAN, 1000) (BUFFER (I), I = 1, WORDS) RETURN 1000 FORMAT (1X, 66A2) END 'EJECT' SUBROUTINE RDSEQ (CHAN, BUFFER, COUNT, ERROR) C READ BIANRY CHARACTERS INTEGER CHAN, COUNT, BUFFER (COUNT), ERROR INTEGER WORDS WORDS = (COUNT + 1)/2 READ (CHAN, 1000, END = 100) (BUFFER (I), I = 1, WORDS) ERROR = 1 RETURN 100 ERROR = 9 RETURN 1000 FORMAT (1A2) END SUBROUTINE WRSEQ (CHAN, BUFFER, COUNT) C WRITE BINARY CHARACTERS INTEGER CHAN, COUNT, BUFFER (COUNT) INTEGER WORDS WORDS = (COUNT + 1)/2 WRITE (CHAN, 1000) (BUFFER (I), I = 1, WORDS) RETURN 1000 FORMAT (1A2) END 'OUTFILE' DEVICEFTM.FR SUBROUTINE DEVICE (FILE) C INSERT "SY0:" AT THE START OF A FILE NAME IF THERE IS C NO DEVICE SPECIFIED C REQUIRED FOR THE PDP/11 INTEGER FILE (16), DEV(2), COLON, I, GCHAR DATA COLON /58/, DEV /'SY0:'/ 'DOLOOP' I = 1, 4 'IF' (GCHAR (FILE, I) .NE. COLON) 'END' 'FOR' (I = 13; I .GE. 1; I = I - 1) FILE (I+2) = FILE (I) 'END' FILE (1) = DEV (1) FILE (2) = DEV (2) 'ENDIF' FILE (16) = 0 // NULL FOR PDP/11 NAME TERMINATION RETURN END