      SUBROUTINE WRTREC(RET)
C
C     THIS ROUTINE COMPLETES THE CREATION OF A STANDARD FORMAT RECORD
C     AND WRITES IT OUT TO THE FILE BEING CREATED.
C
C     PARAMETERS ARE AS FOLLOWS_
C     RET = RETURN FLAG, VALUES ARE_
C            0 - NO ERRORS
C           -1 - NO RECORD READY TO BE WRITTEN
C
C     BRIEF PROCEEDURE DESCRIPTION_
C     RECORD IS ASSEMBLED IN ARRAY AA.
C     ASSEMBLY OF THE LEADER IS COMPLETED IN ARRAY LEAD.
C     THE LEADER IS THEN TRANSFERRED TO ARRAY AA.  THE DIRECTORY IS THEN
C     ASSEMBLED FROM THE VALUES IN ARRAYS ITG AND DIR .  THE FIELD TERMINATOR
C     IS ADDED AND THE DATA ARRAY IS TRANSFERRED TO ARRAY AA.  TAPE BLOCKS
C     ARE ASSEMBLED IN ARRAY BB.  IF THE RECORD JUST ASSEMBLED FITS INTO
C     CURRENT TAPE BLOCK IT IS ADDED AND SUBROUTINE EXITS.  IF THE RECORD
C     DOES NOT FIT INTO THE CURRENT TAPE BLOCK THE BLOCK IS WRITEN AND A
C     NEW BLOCK IS STARTED.  IF A RECORD IS LONGER THAN A TAPE BLOCK,
C     TAPE BLOCK IS EMPTIED (IF NEEDED) AND THE RECORD IS WRITTEN OUT
C     FOLLOWING THE STANDARD.  IT IS ASSUMED THAT THE FIRST CALL TO THIS
C     ROUTINE IS THE CALL TO WRITE THE DDF.  THEREFORE, THE BUFFER WILL
C     BE EMPTIED AND LABELS WILL BE WRITTEN.  IT THE ROUTINE IS CALLED
C     WITH NO DATA IN RECORD ASSEMBLY AREAS (ARRAYS ITG, DIR AND A1) THE
C     JOB IS ABORTED WITH AN ERROR MESSAGE IN THE OUTPUT FILE.
C
      INCLUDE 'SY:DDFCOM.FTN'
      INCLUDE 'SY:FLGCM.FTN'
      LOGICAL*1 DIR2(10,50)
      INTEGER BASE,OVBY
      EQUIVALENCE (DIR(1),DIR2(1,1))
      LOGICAL*1 NTEST(5),PAD,NY(5),CEOF
      LOGICAL*1 AA(3046)                                                 JULY 78
      DATA NFIRST/1/
      DATA LCHM/16/
      DATA LCHN/17/
      DATA LCHTG/18/
      DATA NCHL/19/
      DATA LBASE/5/
      DATA NR/5/
      DATA LEMPT/19/
      DATA PAD/94/
      DATA LPAD/1/
      DATA LRT/1/
      DATA LFLG/1/
      DATA LCHBA/8/
      DATA NWA/1/
      DATA LEOF/1/
      DATA CEOF/28/
      RET=0
      IF(DEBUG) TYPE 2000,A1
 2000 FORMAT(' WRTREC. A1 = ',100A1)
      IF(DEBUG) TYPE 1000,NTG,NCHA
 1000 FORMAT(' NTG = ',I5,' NCHA = ',I5)
      IF(DEBUG) TYPE 2010,ITG
 2010 FORMAT(5(' ITG = ',A8))
C
C     VERIFY THAT RECORD HAS BEEN ASSEMBLED.
C
      IF(NCHA.GT.0) GO TO 18
      PRINT 102
  102 FORMAT (//' -----CALL TO WRITE RECORD ISSUED WITH NO RECORD ASSEMB
     $LED.  JOB ABORTED.-----')
      RET=-1
      RETURN
   18 CONTINUE
C
C     COMPLETE LEADER
C     FIND THE LENGTH OF THE LENGTH-OF-FIELD PORTION OF DIRECTORY
C
      N=5
      IF(NCHM.LT.10000) N=4
      IF(NCHM.LT.1000) N=3
      IF(NCHM.LT.100) N=2
      IF(NCHM.LT.10) N=1
      ENCODE (1,511,NTEST) N
  511 FORMAT(I1)
      NCHM=N
      CALL STRMOV(NTEST,LEAD(LCHM),1)
C
C     LENGTH OF STARTING CHARACTER POSITION PORTION OF DIRECTORY
C
      N=5
      IF(NCHN.LT.10000) N=4
      IF(NCHN.LT.1000) N=3
      IF(NCHN.LT.100) N=2
      IF(NCHN.LT.10) N=1
      ENCODE(1,511,NTEST) N
      NCHN=N
      CALL STRMOV(NTEST,LEAD(LCHN),1)
C
C     TAG LENGTH
C
      ENCODE(1,511,NTEST)LTG
      CALL STRMOV(NTEST,LEAD(LCHTG),1)
C
C     BASE ADDRESS OF DATA
C
      BASE=NCHL+(NTG*(LTG+NCHM+NCHN))+1
      ENCODE (5,510,NTEST) BASE
  510 FORMAT(I5)
C
C     PLACE LEADING ZEROS IN NTEST
C
      CALL LEADZE(NTEST,5)
      CALL STRMOV(NTEST,LEAD(LCHBA),LBASE)
C
C     NUMBER OF CHARACTERS IN DATA ARRAY
C
      NCH=NCHA       
C
C     ASSEMBLE RECORD
C     LEADER
C
      NCHA=1
      CALL STRMOV(LEAD,AA(NCHA),NCHL)
      NCHA=NCHA+NCHL
C
C     DIRECTORY
C
      DO 522 II=1,NTG
C
C     TAG VALUE
C
      CALL STRMOV(ITG(II),AA(NCHA),LTG)
      NCHA=NCHA+LTG
      CALL STRMOV(DIR2((6-NCHM),II),AA(NCHA),NCHM)
      NCHA=NCHA+NCHM
C
C     STARTING CHARACTER POSITION
C
  524 CONTINUE
      CALL STRMOV(DIR2((11-NCHN),II),AA(NCHA),NCHN)
      NCHA=NCHA+NCHN
  522 CONTINUE
      IF(DEBUG) TYPE 2005,AA
 2005 FORMAT(' AA = ',100A1)
C
C     ADD FIELD TERMINATOR
C
      CALL STRMOV(FT,AA(NCHA),LFT)
      NCHA=NCHA+LFT
C
C     DATA ARRAY
C
  529 CONTINUE
      CALL STRMOV(A1,AA(NCHA),NCH)
      IF(DEBUG) TYPE 2005,AA
C
C     BLOCK RECORD.  WRITE BLOCKS.
C     NUMBER OF CHARACTERS INRECORD.
C
      IF(NCH.LE.0) RETURN
      NCH=NCH+BASE
      NC=NCH-1                                                          JUNE 78
      NWA=1
      NA=0
      OVBY=0
C
C     IS ENOUGH ROOM LEFT IN CURRENT BUFFER.
C
    9 CONTINUE
      IF(NCHB+NR+LEMPT-1.LT.NCH1) GO TO 1                               JUNE 78
C
C     NOT ENOUGH! PAD TO NCH1 CHARACTERS IF NECESSARY.
C
      IF(DEBUG) TYPE 2015,NCHB
 2015 FORMAT(' NCHB = ',I5)
      IF(NCHB.GT.NCH1) GO TO 12                                         JUNE,78
   13 CONTINUE
      CALL STRMOV(PAD,BB(NCHB),LPAD)
      NCHB=NCHB+LPAD
      IF(NCHB.LE.NCH1) GO TO 13                                         JUNE,78
C
C     WRITE CURRENT BLOCK
C
   12 N=NCHB-1
      IF(N.LE.NFIRST) GO TO 1
C     CALL WRITE8(BB,N,0)
      CALL WRITE8(BB,NCHB-1,0)
      NCHB=NFIRST
    1 CONTINUE
C
C     CHECK IF RECORD FITS IN CURRENT BLOCK.
C
      N=NCHB+NC+NR+LRT-1                                                JUNE 78
      IF(N.LE.NCH1) GO TO 2
      IF(OVBY.LT.1) OVBY=1
      NCH=NCH1-(NCHB+NR)+1                                              JUNE,78
    2 CONTINUE
C
C     ADD CURRENT RECORD TO BLOCK.
C     LENGTH OF RECORD.
C
      I=NCH+NR
      IF(             OVBY.EQ.3) I=I+1                                  JUNE 78
C
C     BLOCK SPAN INDICATOR AND RECORD LENGTH.
C
      ENCODE(5,107,NY) OVBY,I                                           JUNE,78
  107 FORMAT(I1,I4)
      CALL LEADZE(NY,5)
      CALL STRMOV(NY,BB(NCHB),NR)
      ISAV=I                                                             JULY 78
      NSAV=NCHB                                                          JULY 78
      NCHB=NCHB+NR
C
C     DATA TO BLOCKS
C
      NCX = I-NR                                                        JULY 78
      N=0
      CALL STRMOV(AA(NWA),BB(NCHB),NCX)                                  JULY 78
      NCHB=NCHB+NCX                                                      JULY 78
      NWA=NWA+NCX                                                        JULY 78
      NC=NC-NCH
      IF(NC.LE.0) GO TO 11
      NCH=NC
      OVBY=3
      IF(NC+NR+LRT.LE.NCH1) GO TO 9
      OVBY=2
      GO TO 9
C
C     RECORD ALL IN BLOCK.  ADD END OF RECORD INDICATOR.
C
   11 CONTINUE
C                                                                       JUNE 78
C     CHECH IF EOR FITS IN CURRENT BLOCK                                JUNE 78
C                                                                       JUNE 78
      IF(NCHB+LRT-2.LE.NCH1) GO TO 16                                   JULY 78
C                                                                       JULY 78
C     PATCH THE CHARACTER COUNT                                         JULY 78
C                                                                       JULY 78
      ENCODE(5,107,NY)    1,ISAV-1                                      JULY 78
      CALL LEADZE(NY,5)                                                 JULY 78
      CALL STRMOV(NY,BB(NSAV),NR)                                       JULY 78
C                                                                       JUNE 78
C     NO WRITE CURRENT BLOCK                                            JUNE 78
C                                                                       JUNE 78
      N=NCHB-1                                                          JUNE 78
      CALL WRITE8(BB,N,0)                                               JUNE 78
      NCHB=NFIRST                                                       JUNE 78
C                                                                       JUNE 78
C     BLOCK SPAN INDICATOR + LENGTH OF SEGMENT                          JUNE 78
C                                                                       JUNE 78
      OVBY=3                                                            JUNE 78
      ENCODE(5,107,NY) OVBY,NCHB+NR                                     JUNE 78
      CALL LEADZE(NY,5)                                                 JUNE 78
      CALL STRMOV(NY,BB(NCHB),NR)                                       JUNE 78
      NCHB=NCHB+NR+NFIRST                                               JUNE 78
   16 CONTINUE                                                          JUNE 78
C
C     CHECK IF DDF IS BEING PROCESSED.
C
      IF(LFLG.NE.0) GO TO 77
      CALL STRMOV(RMK,BB(NCHB-1),LRT)
      GO TO 7
   77 CONTINUE
      LFLG=0
C
C     ENDFILE DDF.
C
      CALL STRMOV(CEOF,BB(NCHB-1),LEOF)
C
C     CALCULATE NO OF PAD CHARACTERS REQUIRED TO FILL OUT A EVEN
C     MULTIPLE OF 6 BIT AND 8 BIT CHARACTERS AND 2 CHARACTER WORDS.
C
      NX=NCHB-1
      NZ=NX/6
      NZ2=NZ*6
      NZ3=NX-NZ2
      NZ4=6-NZ3
      IF(NZ4.EQ.6) GO TO 79
      DO 78 I=1,NZ4
      CALL STRMOV(PAD,BB(NCHB),1)
      NCHB=NCHB+1
   78 CONTINUE
   79 CONTINUE
      N=NCHB
      IF(N.LE.NFIRST)N=0
C     CALL WRITE8(BB,N,1)
      CALL WRITE8(BB,NCHB-1,1)
      NCHB=NFIRST
      NWA=NFIRST
      CALL CHGFIL
C
C     REINITIALIZE POINTERS
C
    7 CONTINUE
      DO 15 I=1,19
      LEAD(I)=BBLANK
   15 CONTINUE
      NTG=0
      NWA=1
      NCHA=1
      RETURN
      END
