'HEAD' GENERAL UTILITIES C EDIT DATE 18JUN79 C SOURCE FILE UTILSFFS C AUTHOR B. P. ADLEY C CLUSTER 28 'OUTFILE' GCHAR.FR INTEGER FUNCTION GCHAR(BUF,INDEX) INTEGER BUF(1),INDEX INTEGER SHIFT(4),MASK(4),IPOS DATA MASK/ZFF000000,Z00FF0000,Z0000FF00,Z000000FF/ DATA SHIFT/ -24, -16, -8, 0/ I=ISHFT(INDEX+3,-2) IPOS=IAND(INDEX-1,3)+1 GCHAR=ISHFT(IAND(BUF(I),MASK(IPOS)),SHIFT(IPOS)) RETURN END C C C 'OUTFILE' PCHAR.FR SUBROUTINE PCHAR(BUF,IDX,CHAR) INTEGER BUF(1),IDX,CHAR,SHIFT(4),MASK(4) INTEGER IPOS DATA MASK/Z00FFFFFF,ZFF00FFFF,ZFFFF00FF,ZFFFFFF00/ DATA SHIFT/ 24, 16, 8, 0/ I=ISHFT(IDX+3,-2) IPOS=IAND(IDX-1,3)+1 BUF(I)=IAND(BUF(I),MASK(IPOS))+ISHFT(IAND(CHAR,255),SHIFT(IPOS)) RETURN END 'OUTFILE' SET.FR SUBROUTINE SET(VALUE,BUF,COUNT) INTEGER VALUE,COUNT,BUF(COUNT) INTEGER DVALUE,MASK DATA MASK/Z0000FFFF/ IDX=ISHFT(COUNT,-1) IF(IDX.LE.0)GOTO 20 DVALUE=ISHFT(VALUE,16)+VALUE DO 10 I=1,IDX BUF(I)=DVALUE 10 CONTINUE 20 CONTINUE IF(IAND(COUNT,1).EQ.0)GOTO 30 BUF(IDX+1)=IAND(BUF(IDX+1),MASK)+ISHFT(VALUE,-16) 30 CONTINUE RETURN END C C 'OUTFILE' MOVE.FR SUBROUTINE MOVE(FROMB,TOB,COUNT) INTEGER COUNT,FROMB(COUNT),TOB(COUNT) INTEGER MASK DATA MASK /ZFFFF0000/ IDX=ISHFT(COUNT,-1) IF(IDX.LE.0)GOTO 20 DO 10 I=1,IDX TOB(I)=FROMB(I) 10 CONTINUE 20 CONTINUE IF(IAND(COUNT,1).EQ.0)GOTO 30 TOB(IDX+1)=IAND(TOB(IDX+1),NOT(MASK))+IAND(FROMB(IDX+1),MASK) 30 CONTINUE 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(1), 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(1), BUF(1), 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(1), 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' NAME COMPRESSION ROUTINE 'OUTFILE' NAMCOM.FR SUBROUTINE NAMCOM(BUF,SLEN) INTEGER BUF(1),SLEN,PERIOD INTEGER GCHAR LOGICAL BP DATA PERIOD/46/ BP=.TRUE. DO 50 IK=1,8 IF(.NOT.BP.OR.IK.GT.6.OR.IK.GT.SLEN)GOTO 10 IF(GCHAR(BUF,IK).NE.PERIOD)GOTO 50 IT=IK GOTO 25 10 CONTINUE IF(.NOT.BP)GOTO 30 DO 20 IT=1,SLEN IF(GCHAR(BUF,IT).EQ.PERIOD)GOTO 25 20 CONTINUE GOTO 60 25 CONTINUE BP=.FALSE. 30 CONTINUE IT=IT+1 IF(IT.GT.SLEN)GOTO 60 CALL PCHAR(BUF,IK,GCHAR(BUF,IT)) 50 CONTINUE IK=9 60 CONTINUE SLEN=IK-1 RETURN END 'HEAD' EMAS INTERFACE ROUTINES -- MACHINE DEPENDANT 'OUTFILE' EMASIA.FR SUBROUTINE OPENF(CHAN,FILE,ERROR) INTEGER CHAN,FILE(1),ERROR INTEGER STRING(10) INTEGER CHARF,CHART,COMMA,ZERO,BLANK INTEGER SUCESS,GCHAR DATA CHARF,CHART,COMMA,ZERO,BLANK/70,84,44,48,32/ DATA STRING/10*0/ ERROR=1 IF(CHAN.GT.99.OR.CHAN.LE.0)GOTO 30 CALL PCHAR(STRING,1,CHARF) CALL PCHAR(STRING,2,CHART) CALL PCHAR(STRING,3,CHAN/10+ZERO) CALL PCHAR(STRING,4,MOD(CHAN,10)+ZERO) CALL PCHAR(STRING,5,COMMA) DO 10 IK=1,32 I=GCHAR(FILE,IK) IF(I.EQ.0.OR.I.EQ.32)GOTO 20 CALL PCHAR(STRING,IK+5,I) 10 CONTINUE GOTO 30 20 CONTINUE IK=IK+5 CALL EST(',,C',STRING,IK,IK+2) IK=IK+2 CALL EMASFC('DEFINE',6,STRING,IK) IK=SUCESS(I) IF(IK.EQ.0)GOTO 40 WRITE(6,100)IK 100 FORMAT(' ',' RESULT CODE =',I6) 30 ERROR=-1 40 CONTINUE RETURN END C SUBROUTINE OPENN(CHAN,FILE,ERROR) INTEGER CHAN,FILE(1),ERROR CALL OPENF(CHAN,FILE,ERROR) RETURN END C C 'EJECT' SUBROUTINE CLOSF(CHAN,FILE) INTEGER CHAN,FILE(1) INTEGER STRING,ZERO INTEGER GCHAR DATA STRING,ZERO/' ',48/ CALL CLOSEF(CHAN) CALL PCHAR(STRING,1,CHAN/10+ZERO) CALL PCHAR(STRING,2,MOD(CHAN,10)+ZERO) CALL EMASFC('CLEAR',5,STRING,2) DO 10 IK=1,20 I=GCHAR(FILE,IK) IF(I.EQ.0.OR.I.EQ.32)GOTO 20 10 CONTINUE 20 CONTINUE CALL EMASFC('DISCONNECT',10,FILE,IK-1) RETURN END C C SUBROUTINE DELETE(CHAN,FILE) INTEGER CHAN,FILE(1) INTEGER GCHAR CALL CLOSF(CHAN,FILE) DO 10 IK=1,32 IF(GCHAR(FILE,IK).EQ.0.OR.GCHAR(FILE,IK).EQ.32)GOTO 20 10 CONTINUE 20 CONTINUE CALL EMASFC('DESTROY',7,FILE,IK-1) RETURN END 'HEAD' EMAS INTERFACE ROUTINES 'OUTFILE' EMASIB.FR SUBROUTINE REW(CHAN,FILE) INTEGER CHAN,FILE(1) REWIND CHAN RETURN END C 'EJECT' SUBROUTINE RDLIN (CHAN, BUFFER, MAX, ERROR) C READ AN ASCII LINE (MAX CHARACTERS) INTEGER CHAN, BUFFER (1), MAX, ERROR INTEGER WORDS WORDS = (MAX + 3)/4 READ (CHAN, 1000, END = 100) (BUFFER (I), I = 1, WORDS) ERROR = 1 RETURN 100 ERROR = 9 RETURN 1000 FORMAT (20A4) END SUBROUTINE WRLIN(CHAN,BUFFER,CHARS) INTEGER CHAN,BUFFER(1),CHARS INTEGER WORDS,PNTR,FMT(6),BBBB,Z100,Z3030 DATA FMT/'(','1X',',',1,'A4',')'/ DATA BBBB/' '/,Z100/Z100/,Z3030/Z20203030/ WORDS=(CHARS+3)/4 IT=WORDS+1 DO 10 IK=1,WORDS PNTR=IT-IK IF(BUFFER(PNTR).NE.BBBB)GOTO 20 10 CONTINUE 20 CONTINUE FMT(4)=(PNTR/10*Z100)+(PNTR-(PNTR/10)*10)+Z3030 WRITE(CHAN,FMT)(BUFFER(I),I=1,PNTR) RETURN END 'EJECT' SUBROUTINE RDSEQ (CHAN, BUFFER, COUNT, ERROR) C READ BIANRY CHARACTERS INTEGER CHAN, COUNT, BUFFER (COUNT), ERROR INTEGER WORDS WORDS = (COUNT + 3)/4 READ (CHAN, 1000, END = 100) (BUFFER (I), I = 1, WORDS) ERROR = 1 RETURN 100 ERROR = 9 RETURN 1000 FORMAT (1A4) END SUBROUTINE WRSEQ (CHAN, BUFFER, COUNT) C WRITE BINARY CHARACTERS INTEGER CHAN, COUNT, BUFFER (COUNT) INTEGER WORDS WORDS = (COUNT + 3)/4 WRITE (CHAN, 1000) (BUFFER (I), I = 1, WORDS) RETURN 1000 FORMAT (1A4) END