      SUBROUTINE PUTREC(LUJNK,FILNAM,LABEL,LENGTH,ISTUFF)
C
C THIS ROUTINE PUTS A LOGICAL RECORD ON THE JOBARC FILE.
C
C   INPUT:
C         LUJNK - INTEGER -- ignored
C         FILNAM- CHARACTER*(*) ignored
C         LABEL - IDENTIFIER FOR LOGICAL RECORD.  CHARACTER*(*) STRING.
C         LENGTH- LENGTH OF LOGICAL RECORD IN *INTEGER* WORDS.
C         ISTUFF- CONTENTS OF LOGICAL RECORD.
C
CEND
      IMPLICIT INTEGER(A-Z)
      PARAMETER (IBUFLN = 128)
      PARAMETER (LUFIL = 75)
      CHARACTER*(*) LABEL
      CHARACTER*8 MARKER
      CHARACTER*80 FNAME1
      CHARACTER*(*) FILNAM
      DIMENSION ISTUFF(LENGTH),IBUF(IBUFLN)
      COMMON /FILES/ LUOUT,MOINTS
      COMMON /MACHSP/ IINTLN,IFLTLN,IINTFP,IALONE,IBITWD
      COMMON /JOBARC/ MARKER(1000),LOC(1000),SIZE(1000),NRECS,
     &                IRECWD,IRECLN
      IF(LENGTH.EQ.0)RETURN
c
      CALL GFNAME('JOBARC  ',FNAME1,ILENGTH1)

          OPEN(UNIT=LUFIL,FILE=FNAME1(1:ILENGTH1),
     &         FORM='UNFORMATTED',STATUS='OLD',
     &         ACCESS='DIRECT',RECL=IRECLN)
C
C LOCATE POINTER TO SEE IF A RECORD WITH THIS LABEL HAS BEEN WRITTEN
C  PREVIOUSLY.  IF TRUE, THEN MAKE SURE THAT THIS LENGTH DOES NOT
C  EXCEED THE ORIGINAL LENGTH.  IF IT DOES, ABORT.
C
      ILOC=LOCCHR(1000,MARKER,1,LABEL)
      IF(ILOC.EQ.1001)THEN
       ILOC=LOCCHR(1000,MARKER,1,'OPENSLOT')
       IF(ILOC.GE.1001)THEN
        WRITE(LUOUT,1000)
1000    FORMAT(T3,'@PUTREC-F, Maximum allowable number of records ',
     &            'exceeded in JOBARC.',/,T3,'@PUTREC-F, Redimension ',
     &            'arrays in common block JOBARC.')
       ENDIF
       MARKER(ILOC)=LABEL
       SIZE(ILOC)=LENGTH
       IF(ILOC.NE.1)THEN
        LOC(ILOC)=LOC(ILOC-1)+SIZE(ILOC-1)
       ELSE
        LOC(ILOC)=1
       ENDIF
      ELSE
       IF(LENGTH.GT.SIZE(ILOC))THEN
        WRITE(LUOUT,1001) MARKER(iloc), LENGTH,SIZE(ILOC)
1001    FORMAT(T3,'@PUTREC-F, Size of record ',A8,'[',I8,'words ] ',
     &           'exceeds original length of ',I8,'.')
        CALL ERREX
       ENDIF
      ENDIF
C
C FIND WORD ADDRESS OF FIRST ELEMENT ON RECORD, COMPUTE ADDRESS OF LAST
C  WORD AND THEN COMPUTE BEGINNING AND ENDING RECORD NUMBERS, AND WORD
C  OFFSETS.
C
C  IWRDST - THE ABSOLUTE WORD ADDRESS WHERE THE ARRAY BEGINS.
C  IWRDEN - THE ABSOLUTE WORD ADDRESS WHERE THE ARRAY ENDS.
C  IRECST - THE PHYSICAL RECORD WHERE IWRDST IS LOCATED.
C  IRECEN - THE PHYSICAL RECORD WHERE IWRDEN IS LOCATED.
C  IOFFST - THE RELATIVE WORD ADDRESS OF IWRDST ON RECORD IRECST.
C  IOFFEN - THE RELATIVE WORD ADDRESS OF IWRDEN ON RECORD IRECEN.
C  NWRDST - THE NUMBER OF WORDS TRANSFERRED TO/FROM IRECST.
C  NWRDEN - THE NUMBER OF WORDS TRANSFERRED TO/FROM IRECEN.
C
      IWRDST=LOC(ILOC)
      IRECST=1+IWRDST/IRECWD
      IOFFST=MOD(IWRDST,IRECWD)
      IF(IOFFST.EQ.0)THEN
       IRECST=IRECST-1
       IOFFST=IRECWD
      ENDIF
      NWRDST=IRECWD-IOFFST+1
      IWRDEN=LOC(ILOC)+LENGTH-1
      IRECEN=1+IWRDEN/IRECWD
      IOFFEN=MOD(IWRDEN,IRECWD)
      IF(IOFFEN.EQ.0)THEN
       IRECEN=IRECEN-1
       IOFFEN=IRECWD
      ENDIF
      NWRDEN=IOFFEN
      IF(IRECEN.EQ.IRECST)THEN
C
C CASE ONE.  ALL INFORMATION ON ONE RECORD.
C
       IF(IRECST.LE.NRECS)READ(LUFIL,REC=IRECST,ERR=999,
     &                         IOSTAT=IOS)IBUF
       CALL ICOPY(LENGTH,ISTUFF,1,IBUF(IOFFST),1)
       WRITE(LUFIL,REC=IRECST,ERR=999,IOSTAT=IOS)IBUF
       NRECS=MAX(NRECS,IRECST)
       close(75)
       RETURN
      ELSE
C
C CASE TWO.  INFORMATION SPREAD ACROSS SEVERAL RECORDS.  FIRST PUT BOTTO
C  OF ISTUFF ONTO FIRST RECORD.
C
       IOFF=1
       IF(IRECST.LE.NRECS)READ(LUFIL,REC=IRECST,ERR=999,
     &                         IOSTAT=IOS)IBUF
       CALL ICOPY(NWRDST,ISTUFF(IOFF),1,IBUF(IOFFST),1)
       WRITE(LUFIL,REC=IRECST,ERR=999,IOSTAT=IOS)IBUF
       NRECS=MAX(NRECS,IRECST)
       IOFF=IOFF+NWRDST
C
C NOW PICK UP STUFF FROM INTERVENING RECORDS.
C
       DO 10 I=IRECST+1,IRECEN-1
        IF(I.LE.NRECS)READ(LUFIL,REC=I,ERR=999,
     &                     IOSTAT=IOS)IBUF
        CALL ICOPY(IRECWD,ISTUFF(IOFF),1,IBUF,1)
        WRITE(LUFIL,REC=I,ERR=999,IOSTAT=IOS)IBUF
        NRECS=MAX(NRECS,I)
        IOFF=IOFF+IRECWD
10     CONTINUE
C
C NOW GET STUFF OFF LAST RECORD
C
       IF(IRECEN.LE.NRECS)READ(LUFIL,REC=IRECEN,ERR=999,
     &                         IOSTAT=IOS)IBUF
       CALL ICOPY(NWRDEN,ISTUFF(IOFF),1,IBUF,1)
       WRITE(LUFIL,REC=IRECEN,ERR=999,IOSTAT=IOS)IBUF
       NRECS=MAX(NRECS,IRECEN)
       close(75)
       RETURN
      ENDIF
c
999   CONTINUE
      WRITE(LUOUT,51)LUFIL,LABEL,IOS
      CALL ERREX
51    FORMAT(T3,'@PUTREC-F, I/O error on unit ',I3,' while trying ',
     &'to write ',A10,'.',/,T3,' System IOSTAT error number is ',
     &I3,'.')
      END
