FTN4,L,C
      PROGRAM BORL
C 
C 
C*************************************************************
C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.  ALL RIGHTS    *
C RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C*************************************************************
C 
C 
C     LISTING:   92063-19009
C     SOURCE:    92063-18009
C     RELOC:     92063-16009
C 
C 
C************************************************************ 
C 
C 
C  THIS PROGRAM WILL BUILD THE FILE 'HELPF' OR
C  LIST THE CONTENTS OF THE FILE '%HELP'. 
C 
      INTEGER DIR(128),DATA(128),RSN
      DIMENSION IBUF(41),INAM(3),NAME(3),ISIZE(2) 
      COMMON IBUF,INAM,NAME,DATA,NDATA,RSN,LU 
      COMMON IDCBW(144),IDCBR(144),IERR 
C 
C  INITIALIZE ARRAYS AND VARIABLES
C 
      DO 1 J=1,128
      DIR(J)=0
    1 DATA(J)=0 
      NDATA=1 
      RSN=2 
      NDIR=5
      NWDS=5
      NAME(1)=2HHE
      NAME(2)=2HLP
      NAME(3)=2HF 
      INAM(1)=2H%H
      INAM(2)=2HEL
      INAM(3)=2HP 
      ISIZE(1)=-1 
      ISIZE(2)=128
      CALL OPEN(IDCBR,IERR,INAM)
      IF (IERR.LT.0) GOTO 6 
      IF (ISSW(15)) 10,4
    4 CALL CREAT(IDCBW,IERR,NAME,ISIZE,2) 
      IF (IERR.GE.0) GOTO 5 
    6 CALL FMERR(IERR,6)
7     CALL CLOSE(IDCBR) 
      CALL LOCF(IDCBW,IERR,IREC,IRB,IOFF,JSEC)
      CALL CLOSE(IDCBW,IERR,(JSEC/2-RSN+1)) 
      CALL EXEC(6)
C 
C****************** 
C* VARIABLE NAMES * 
C****************** 
C 
C  DIR    128 WD BUFFER FOR DIRECTORY 
C  NDIR   POINTER TO START OF NEXT DIRECTORY ENTRY
C  NWDS   NO OF WORDS PER DIRECTORY ENTRY 
C  DATA   128 WD BUFFER FOR DISC OUTPUT 
C  NDATA  POINTER TO START OF NEXT RECORD IN DATA 
C  RSN    RELATIVE SECTOR NUMBER
C  IBUF   41 WD BUFFER FOR INPUT RECORD 
C  INAM   FILE MAME '%HELP' 
C  NAME   FILE NAME 'HELPF' 
C  LOG    INPUT RECORD SIZE (WORDS) 
C  LU     INPUT DEVICE LU 
C 
C 
C  CHECK SWITCH REG BIT(15)  ON = PRINT DATA FILE - %HELP 
C                           OFF = BUILD DATA FILE - HELPF 
5     IF (ISSW(15)) 10,100
C 
C  GET NEW PAGE ON PRINTER
C 
   10 CALL EXEC(3,1106B,-1) 
C 
C  **     END OF DATA 
C   1     SPACE LINE
C  %%     END OF COMMAND DESCRIPTION
C 
   20 CALL READF(IDCBR,IERR,IBUF(2),40,LOG) 
      IF (IERR.LT.0) GOTO 6 
      IF (IBUF(2).EQ.2H**) STOP 
      IF (IBUF(2).EQ.2H 1) GO TO 30 
      IF (IBUF(2).EQ.2H%%) GO TO 10 
      IBUF(1)=2H
      WRITE(6,40) (IBUF(I),I=1,LOG) 
      GO TO 20
   30 WRITE (6,40)
      GO TO 20
   40 FORMAT (2X,40R2)
C 
C  READ IN FIRST DATA RECORD IN A GROUP 
C  OF RECORDS DESCRIBING A COMMAND
C 
C  IF FIRST WORD = ** (END OF FILE) 
C 
  100 CALL READF(IDCBR,IERR,IBUF(2),40,LOG) 
      IF (IERR.EQ.-12) GOTO 105 
      IF (IERR.LT.0) GOTO 6 
105   IF (IBUF(2).EQ.2H**) GO TO 300
      IF (LOG-2) 120,110,120
  110 DIR(NDIR)=20040B
      DIR(NDIR+1)=20040B
      GO TO 130 
  120 CALL SMOVE(IBUF,8,11,DIR,2*NDIR-1)
  130 NDIR=NDIR+2 
      DIR(NDIR)=RSN 
      NDIR=NDIR+1 
C 
C  READ NEXT RECORD(S) UNTIL %% MARK
C  OR UNTIL CHANGE OF FUNCTION
C  (I.E.  F, S, O)
C 
  200 CALL READF(IDCBR,IERR,IBUF(2),40,LOG) 
      IF (IERR.LT.0) GOTO 6 
      IBUF(1)=LOG 
      IF (IBUF(2).NE.2H%%) GO TO 210
      CALL WDISC
      IF (IERR.LT.0) GOTO 6 
      GO TO 100 
C 
C  SUBSTITUTE CR/LF 
C 
  210 IF (IBUF(2).EQ.2H 1) IBUF(2)=6412B
C 
      IF (IBUF(2).EQ.2H S) GO TO 220
      IF (IBUF(2).EQ.2H O) GO TO 220
      GO TO 225 
C 
C  WRITE LAST DISC SECTOR FOR THIS COMMAND
C 
  220 CALL WDISC
      IF (IERR.LT.0) GOTO 6 
      DIR(NDIR)=RSN 
      NDIR=NDIR+1 
C 
C  IF THERE IS ROOM FOR THIS RECORD IN THE
C  CURRENT SECTOR BUFFER (RECORD LEN + 2),
C  MOVE THE RECORD TO THE BUFFER
C 
  225 K=LOG+2 
      IF (129-NDATA-K) 230,240,240
  230 DATA(NDATA)=-1
      CALL WDISC
      IF (IERR.LT.0) GOTO 6 
C 
C  MOVE DATA TO OUTPUT BUFFER 
C 
  240 K=NDATA+LOG 
      J=0 
      DO 250 I=NDATA,K
      J=J+1 
  250 DATA(I)=IBUF(J) 
      NDATA=NDATA+J 
      GO TO 200 
C 
C  FINISH THE DIRECTORY 
C 
  300 DIR(4)=NWDS 
      DIR(3)=NDIR/NWDS
      DIR(2)=RSN-1
      DIR(1)=NDIR-1 
C 
C  WRITE THE DIRECTORY
C 
      CALL WRITF(IDCBW,IERR,DIR,128,1)
      GOTO 7
      END 
      SUBROUTINE WDISC
      COMMON IBUF(41),INAM(3),NAME(3),IDATA(128),NDATA,IRSN,LU
      COMMON IDCBW(144),IDCBR(144),IERR 
C 
      CALL WRITF(IDCBW,IERR,IDATA,128,IRSN) 
      IRSN=IRSN+1 
      NDATA=1 
      DO 10 I=1,128 
   10 IDATA(I)=0
      RETURN
      END 
$END
FTN4,L,C
      SUBROUTINE WDISC
      COMMON IBUF(41),INAM(3),NAME(3),IDATA(128),NDATA,IRSN,LU
      COMMON IDCBW(144),IDCBR(144),IERR 
C 
      CALL WRITF(IDCBW,IERR,IDATA,128,IRSN) 
      IRSN=IRSN+1 
      NDATA=1 
      DO 10 I=1,128 
   10 IDATA(I)=0
      RETURN
      END 
$ 
                                                                                                                                                