C PROGRAM TO UPDATE XREC C INPUT IS : C C VARIABLE NAME C \GROUP NAME C VARIABLE VALUE C N,N,N,N, DECUS NUMBERS TO UPDATE C \ NEW GROUP ETC IMPLICIT INTEGER (A-Z) LOGICAL FIRST CHARACTER XREC*300,NAME*15,I$$NAME(300)*15 DIMENSION I$$START(300) CHARACTER INGROUP*3,CATEGORY*4,INNUMBER*4,INDEX*7 CHARACTER*80 MESSAGE DIMENSION INPRGS(30) EXTERNAL OPEN_IDX 1000 FORMAT($,' GROUP ') 2000 FORMAT(A) 3000 FORMAT(1X,A) 4000 FORMAT(30I4) 5000 FORMAT(I4) 6000 FORMAT(' ERROR ON WRITING ',A,/,1X,A) 7000 FORMAT(' UPDATING : ',A) 8000 FORMAT(' OVER WRITING : ',A) INCLUDE 'XREC.FOR/NOLIST' I$$LEN=I$$START(N+1)-1 OPEN (UNIT=2,NAME='CATEGORY',TYPE='OLD',READONLY) READ(2,2000)NAME WRITE(6,7000)NAME DO 10 I=1,N 10 IF(NAME.EQ.I$$NAME(I))GOTO 20 STOP 'VARIABLE IS UNKNOWN' 20 I1=I$$START(I) I2=I$$START(I+1)-1 IL=I2-I1+1 FIRST=.TRUE. CALL INIT_IDX (XREC(1:I$$LEN)) OPEN (UNIT=1,NAME='XLIB.DTR',USEROPEN=OPEN_IDX) 100 READ (2,2000,END=900)MESSAGE IF(MESSAGE(1:1).EQ.'\')THEN INGROUP=MESSAGE(2:4) FIRST=.FALSE. GOTO 100 ELSE IF(FIRST)STOP 'GROUP NAME MISSING' CATEGORY=MESSAGE(1:IL) ENDIF 200 READ (2,4000)INPRGS I=0 300 I=I+1 IF(INPRGS(I).EQ.0)GOTO 100 ENCODE(4,5000,INNUMBER)INPRGS(I) DO 303 J=1,4 303 IF(INNUMBER(J:J).EQ.' ')INNUMBER(J:J)='0' INDEX=INGROUP//INNUMBER WRITE(4,1235)I,INPRGS(I),INDEX 1235 FORMAT(I10,I6,2X,A) J=2 CALL READ_IDX(INDEX,J) IF(.NOT.J)THEN CALL SYS$GETMSG(%VAL(J),N,MESSAGE,%VAL(15),) WRITE(3,6000)INDEX,MESSAGE GOTO 300 END IF IF(XREC(I1:I2).NE.' ')THEN WRITE(4,8000)XREC(I1:I2) ENDIF XREC(I1:I2)=CATEGORY CALL UPDATE_IDX(J) IF(.NOT.J)THEN CALL SYS$GETMSG(%VAL(J),N,MESSAGE,%VAL(15),) WRITE(3,6000)INDEX,MESSAGE END IF GOTO 300 900 STOP END