FTN4,L C C *************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * C * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* C * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C *************************************************************** C C SOURCE PART NUMBER :92067-18380 C C RELOCATABLE PART NUMBER : 92067-16361 C C PROGRAMER(S) : J.M.N. C C C C ACAST ALTERS SST FOR EITER GROUP C OR USER SST C C INPUT SST'S START IN LDCB(15) C NUMBER OF CHANGES ARE IN LDCB(14) C C CALLING SEQUENCE: C CALL ACAST(JBUF(33)) FOR USER C CALL ACAST(NBUF(6+IOFST)) FOR GROUP C SUBROUTINE ACAST(JBUF) ,92067-16361 REV.1940 781024 DIMENSION JBUF(64) COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) KEND=LDCB(14) JEND=JBUF(1) IF(JEND.LT.0) JEND=-JEND-1 C C LOOP FOR ALL CHANGES C IF(KEND.LT.15) GO TO 700 DO 600 K=15,KEND IF(JEND.LE.0) GO TO 200 C C SEARCH FOR MATCH C DO 100 J=2,JEND+1 IF(IAND(LDCB(K),77B).EQ.IAND(JBUF(J),77B)) GO TO 300 100 CONTINUE C C NO MATCH C 200 IF(IAND(LDCB(K),128).EQ.128) GO TO 600 C C ADD ENTRY C JEND=JEND+1 JBUF(JEND+1)=LDCB(K) GO TO 600 C C FOUND MATCH C 300 IF(IAND(LDCB(K),128).NE.128) GO TO 500 C C DELETE ENTRY C DO 400 JJ=J,JEND 400 JBUF(JJ)=JBUF(JJ+1) JEND=JEND-1 GO TO 600 500 JBUF(J)=LDCB(K) 600 CONTINUE C C FIX JBUF(1) C 700 IF(JBUF(1).LT.0) JEND=-JEND JBUF(1)=JEND RETURN END