*     COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979, 1980
*
      BLOCK DATA COPYRIT3
      INTEGER COPYRITE(16)
     1   /'COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979,'
     2  , ' 1980.  '/
      GLOBAL COPYRITE
      END
************************************************************************
*                                                                      *
*            MAIN PROGRAM: EXTRACTION                 @1978 11 01*
*                                                                      *
*     THIS ROUTINE FORMS AN INTERNAL REPRSENTATION OF THE              *
*     USER'S DATABASE AND USES IT TO EXTRACT THE RECORDS               *
*     REQUIRED FOR THE VALIDATION PROCESS.                             *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD
      WRITE (108,40)
40    FORMAT (' EVAL_2 A00 HERE')
      WRITE (108,50)
50    FORMAT (' EXTRACTING SET POINTERS FROM EDMS DATA BASE ')
      WRITE (108,60)
60    FORMAT ('      AND CREATING EVAL_WF2 AND EVAL_WF3')
      CALL EXTINI
      CALL SCHINI
      CALL BLSCHM(ERRCD)
      IF(ERRCD.NE.0)CALL ABORT
      CALL EXTRCT(ERRCD)
      IF(ERRCD.NE.0)CALL ABORT
      STOP 'EXTRACTION COMPLETE'
      END
      SUBROUTINE EXTINI
************************************************************************
*                                                                      *
*            SUBROUTINE EXTINI                       @1978 11 01       *
*                                                                      *
*            DEFINES THE ELEMENTS OF /USERIO/                          *
*            DEFINES ELEMENTS OF /EXSTAT/                              *
*            DEFINES THE ELEMENTS OF /DBSEIO/                          *
*            DEFINES THE ELEMENTS OF /VALDIO/                          *
*            DEFINES ELEMENTS OF /DBRECS/                              *
*            DEFINES ELEMENTS OF /EGBLK/                               *
*            DEFINES ELEMENTS OF /PTBLK/                               *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INCLUDE EVAL_IN02,LIST
      UERROR=7
      UUSERI=5
      UUSERO=6
      UEGFIL=3
      UPTFIL=4
      UEXCTL=2
      UDBARA=11
      CAREAI=1
      CURPGE=0
*
*  INITIALIZE STATISTICS
*
      DBRCNT=0
      OFRCNT=0
      EGBCNT=0
      PTBCNT=0
*
*  SET UP TO FORCE A PAGE READ ON FIRST CALL TO RDDBR
*
      LINCNT=0
      LINPTR=0
*
*  INITIALIZE BLOCKING BUFFER POINTERS
*
      EGBPTR=0
      PTBPTR=0
*
*  SET OUTPUT FILE BLOCKING FACTORS AND BUFFER SIZES
*
      EGBFTR=500
      EGBSIZ=EGBFTR*6
      PTBFTR=500
      PTBSIZ=PTBFTR*5
      RETURN
      END
      SUBROUTINE EXTRCT(ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE EXTRCT                       @1978 11 01       *
*                                                                      *
*     CONTROLS THE READING AND RECORD GENERATION PHASES OF THE         *
*     EXTRACTION ALGORITHM. INITIALIZES THE READ PROCESS TO            *
*     THE BEGINNING OF THE DATABASE.                                   *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD
      LOGICAL EOFFLG
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            EOFFLG   LOGICAL     FLAG TO SIGNAL END OF DATABASE PAGES *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN02
*
*  SET THE POINTER SIZE
*
      PTRSIZ=4
      IF(ARACNT.EQ.1)PTRSIZ=3
10    CONTINUE
      CALL RDDBR(EOFFLG,ERRCD)
      IF(ERRCD.NE.0)GOTO 20
      IF(EOFFLG)GOTO 30
      CALL GENREC(ERRCD)
      IF(ERRCD.NE.0)GOTO 40
      GOTO 10
30    CONTINUE
      CALL WREGBF(ERRCD)
      IF(ERRCD.NE.0)GOTO 60
      CALL WRPTBF(ERRCD)
      IF(ERRCD.NE.0)GOTO 70
      GOTO 90
****************************************
*                                      *
*            ERROR RETURNS             *
****************************************
20    CONTINUE
      WRITE(UERROR,1000)
1000  FORMAT(' ERRORED READING DATABASE RECORD')
      GOTO 50
40    CONTINUE
      WRITE(UERROR,2000)
2000  FORMAT(' ERRORED GENERATING EXTRACTION RECORDS')
      GOTO 50
60    CONTINUE
      WRITE(UERROR,4000)
4000  FORMAT(' ERRORED IN FINAL DUMP OF EG OUTPUT BUFFER')
      GOTO 50
70    CONTINUE
      WRITE(UERROR,5000)
5000  FORMAT(' ERRORED IN FINAL DUMP OF PT OUTPUT BUFFER')
50    CONTINUE
      ERRCD=1
      WRITE(UERROR,3000)
3000  FORMAT(' EXTRACTION PROCESS ABORTED')
****************************************
*                                      *
*          DUMP STATISTICS             *
*                                      *
****************************************
90    CONTINUE
      WRITE(UUSERO,9000)DBRCNT,OFRCNT,EGBFTR,EGBCNT,PTBFTR,PTBCNT
9000  FORMAT(' +',45('-'),'+'/' | ',I10,
     @' DATABASE RECORDS PROCESSED',6X,' |'/' |',45X,'|'/
     @' | ',I10,' LOGICAL RECORDS IN OUTPUT FILES  |'/
     @' +',7('-'),'+',17('-'),'+',19('-'),'+'/
     @' |  FILE | BLOCKING FACTOR | NUMBER OF RECORDS |'/
     @' +',7('-'),'+',17('-'),'+',19('-'),'+'/
     @' |   EG  |',7X,I3,7X,'|',4X,I10,5X,'|'/
     @' +',7('-'),'+',17('-'),'+',19('-'),'+'/
     @' |   PT  |',7X,I3,7X,'|',4X,I10,5X,'|'/
     @' +',7('-'),'+',17('-'),'+',19('-'),'+'/)
      RETURN
      END
      SUBROUTINE RDDBR(EOFFLG,ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE RDDBR                        @1978 11 01       *
*     GETS THE NEXT RECORD ON THE PAGE BY INCREMENTING THE LINE        *
*     POINTER, LINPTR IN /DBRECS/. IF NO NEXT RECORD EXISTS THEN A     *
*     NEW PAGE IS OBTAINED BY RDDBPG. THE AREA AND PAGE RANGE OF EACH  *
*     RECORD IS CHECKED, WITH ANY INCONSISTENCIES BEING DUMPED TO      *
*     THE USER. LINE AND GROUP NUMBERS ARE PULLED FOR EACH RECORD.     *
*     A RECORD REPRESENTING THE PAGE HEADER IS GENERATED. AFTER        *
*     EACH RECORD HAS BEEN SCANNED, AN INDEX ARRAY TO GIVE THE         *
*     LINES OUT IN SORTED ORDER IS PRODUCED. AND THE LINE              *
*     POINTER IS SET TO THE FIRST RECORD.                              *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,GRPSI,REFBUF,REFCNT,NAMCNT,NAMEND,I,GPNO,GPSB,INDEX0
      INTEGER SHIFT,CURHDR,CUREND,BLDREF,PULFLD,FNDGRP
      LOGICAL EOFFLG
      DIMENSION REFBUF(16)
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            GRPSI    INTEGER     SIZE OF GROUP IN WORDS               *
*            REFBUF   INTEGER     BUFFER FOR FORMATTED REFCODE         *
*            REFCNT   INTEGER     LENGTH OF REFCODE FOR FORMAT         *
*            NAMEND   INTEGER     LENGTH OF A NAME FOR FORMAT          *
*            I        INTEGER     A SCRATCH OUTPUT LOOP INDEX          *
*            GPNO     INTEGER     LOCAL GROUP NUMBER OF CURRENT RECORD *
*            GPSB     INTEGER     LOCAL GROUP INDEX OF CURRENT RECORD  *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            SHIFT    INTGEER      A SCRATCH VARIABLE
*            CURHDR   INTEGER     THE FIRST WORD OF THE CURRENT        *
*                                 RECORD (ORIGIN 1)                    *
*            CUREND   INTEGER     THE LAST WORD OF THE CURRENT         *
*                                 RECORD (ORIGIN 1)                    *
*            BLDREF   FUNCTION    MAKES AN EDMS REFCODE                *
*            PULFLD   FUNCTION    PULLS A FIELD FROM A WORD            *
*            FNDGRP   FUNCTION    RETURNS THE INDEX NUMBER OF A GROUP  *
*            EOFFLG   LOGICAL     FLAG TO SIGNAL END OF DATABASE PAGES *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN02
      ERRCD=0
      EOFFLG=.FALSE.
      LINPTR=LINPTR+1
      IF(LINPTR.GT.LINCNT)GOTO 120
      LINSUB=LINSRT(LINPTR)
      RETURN
*
*  GET A NEW PAGE
*
120   CONTINUE
      CALL RDDBPG(EOFFLG,ERRCD)
      IF(ERRCD.NE.0)GOTO 20
      IF(EOFFLG)LINCNT=0;RETURN
*
*  GOT THE PAGE; GENERATE A DUMMY CONTROL SET POINTER GROUP OCCURANCE
*
      LINCNT=1
      CURHDR=1
      CUREND=2
      RECHDR(1)=1
      RECEND(1)=2
      LINNBR(1)=0
      DELIND(1)=0
      GRPSUB(1)=FNDGRP(131072,0)
      REFCDE(1)=BLDREF(AREA(CAREAI),PGENUM,0)
*
*  ADVANCE END POINTER TO NEXT RECORD AND PULL THE PACKED HEADER INFO
*
10    CONTINUE
      CURHDR=CUREND+1
      IF(CURHDR.GT.WRDCNT)GOTO 130
      LINCNT=LINCNT+1
      GRPSI=PULFLD(23,9,PGEBUF(CURHDR))
      CUREND=CURHDR+GRPSI-1
      DELIND(LINCNT)=PULFLD(18,1,PGEBUF(CURHDR))
      RECHDR(LINCNT)=CURHDR
      RECEND(LINCNT)=CUREND
      LINNBR(LINCNT)=PULFLD(0,8,PGEBUF(CURHDR))
      GPNO=PULFLD(8,10,PGEBUF(CURHDR))
      GRPNBR(LINCNT)=GPNO
*
*  CHECK AREA NUMBER AND PAGE RANGE
*
      GPSB=FNDGRP(GPNO,AREA(CAREAI))
      GRPSUB(LINCNT)=GPSB
      REFCDE(LINCNT)=BLDREF(AREA(CAREAI),PGENUM,LINNBR(LINCNT))
      IF(GPSB.EQ.0)GOTO 50
      IF(GRPARA(GPSB).EQ.AREA(CAREAI).OR.GRPARA(GPSB).EQ.0)GOTO 30
*
*  WRONG AREA!
*
      CALL REFFMT(REFCDE(LINCNT),REFBUF)
      REFCNT=REFBUF(1)+1
      NAMCNT=GRPNAM(GPSB,1)
      IF(NAMCNT.LE.0)GOTO 60
      NAMEND=NAMCNT+1
      WRITE(UUSERO,1000)(GRPNAM(GPSB,I),I=1,NAMEND),
     @(REFBUF(I),I=1,REFCNT)
1000  FORMAT(/1X,NA1,' OCCURANCE WITH REFCODE ',NA1)
      GOTO 70
60    CONTINUE
      WRITE(UUSERO,2000)GPNO,(REFBUF(I),I=1,REFCNT)
2000  FORMAT(/' GROUP #'I,'OCCURANCE WITH REFCODE ',NA1)
70    CONTINUE
      NAMCNT=ARANAM(CAREAI,1)
      IF(NAMCNT.LE.0)GOTO 80
      NAMEND=NAMCNT+1
      WRITE(UUSERO,5000)(ARANAM(CAREAI,I),I=1,NAMEND)
5000  FORMAT(' FOUND IN WRONG AREA: ',NA1)
      GOTO 40
80    CONTINUE
      WRITE(UUSERO,6000)AREA(CAREAI)
6000  FORMAT(' FOUND IN WRONG AREA: #',I)
      GOTO 40
30    CONTINUE
      IF(PGENUM.GE.GRPRNG(GPSB,1).AND.
     @PGENUM.LE.GRPRNG(GPSB,2).OR.GRPRNG(GPSB,1).EQ.-1)GOTO 40
*
*  OUT OF ALLOWED PAGE RANGE
*  IF ITS AN INDEXED GROUP, THEN IGNORE IT.
*
      IF(GRPLCM(GPSB).EQ.3)GOTO 40
      CALL REFFMT(REFCDE(LINCNT),REFBUF)
      REFCNT=REFBUF(1)+1
      NAMCNT=GRPNAM(GPSB,1)
      IF(NAMCNT.LE.0)GOTO 90
      NAMEND=NAMCNT+1
      WRITE(UUSERO,1000)(GRPNAM(GPSB,I),I=1,NAMEND),
     @(REFBUF(I),I=1,REFCNT)
      GOTO 100
90    CONTINUE
      WRITE(UUSERO,2000)GPNO,(REFBUF(I),I=1,REFCNT)
100   CONTINUE
      WRITE(UUSERO,7000)PGENUM
7000  FORMAT(' FOUND ON PAGE #',I,', OUTSIDE DECLARED RANGE')
40    CONTINUE
      GOTO 10
*
*  SORT THE LINE NUMBERS. SINCE LINE NUMBERS ARE UNIQUE AND
*  IN A KNOWN RANGE, THIS IS DONE BY FORMING AN INDEX ARRAY
*  THROUGH SIMPLE ASSIGNMENT. THE INDEX ARRAY, LINSRT IS
*  ZEROED FIRST. THEN SQUEEZE OUT NONZERO VALUES FROM THE
*  FIRST LINCNT ELEMENTS OF LINSRT. THIS MAKES LINSRT A
*  "NICE" SORT INDEX.
*
130   CONTINUE
      DBRCNT=DBRCNT+LINCNT
      DO 140 INDEX0=1,256
      LINSRT(INDEX0)=0
140   CONTINUE
      DO 150 INDEX0=1,LINCNT
      LINSRT(LINNBR(INDEX0)+1)=INDEX0
150   CONTINUE
      SHIFT=0
      DO 160 INDEX0=1,LINCNT
170   CONTINUE
      IF(LINSRT(INDEX0+SHIFT).NE.0)GOTO 180
      SHIFT=SHIFT+1
      GOTO 170
180   CONTINUE
      LINSRT(INDEX0)=LINSRT(INDEX0+SHIFT)
160   CONTINUE
      LINPTR=1
      LINSUB=LINSRT(1)
      RETURN
****************************************
*                                      *
*            ERROR RETURNS             *
****************************************
50    CONTINUE
      ERRCD=1
      WRITE(UERROR,4000)GPNO,PGENUM,AREA(CAREAI)
4000  FORMAT(' HIT AN UNDEFINED GROUP; GROUP #',I,'ON PAGE ',I,
     @'AREA ',I)
20    CONTINUE
      WRITE(UERROR,3000)
3000  FORMAT(' ERRORED WHILE TRYING TO GET A DATABASE RECORD')
      RETURN
      END
      SUBROUTINE RDDBPG(EOFFLG,ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE RDDBPG                       @1978 11 01       *
*                                                                      *
*     READS DATABASE PAGES UNTIL A DATA TYPE PAGE OR END               *
*     OF DATA BASE. SKIPS AUTOMATICALLY FROM AREA TO AREA.             *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,UCAREA,PGETYP,SPAVBL,PULFLD
      LOGICAL EOFFLG
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            UCAREA   INTEGER     UNIT NUMBER FOR THE CURRENT AREA     *
*                                 OF AREA TO GET CURRENT PAGE          *
*            PGETYP   INTEGER     EDMS PAGE TYPE CODE                  *
*            SPAVBL   INTEGER     SPACE AVAILABLE ON CURRENT PAGE      *
*            PULFLD   FUNCTION    PULLS A FIELD FROM A WORD            *
*            EOFFLG   LOGICAL     FLAG TO SIGNAL END OF DATABASE PAGES *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN02
      EOFFLG=.FALSE.
      ERRCD=0
30    CONTINUE
      IF(ARASIZ(CAREAI).GT.CURPGE)GOTO 10
      IF(CAREAI.EQ.ARACNT)GOTO 20
      CAREAI=CAREAI+1
      CURPGE=0
      GOTO 30
10    CONTINUE
      UCAREA=UDBARA+CAREAI-1
      CALL RDDISC(UCAREA,CURPGE,PGEBUF)
      CURPGE=CURPGE+1
*
*  ANY DECIPHERING IS TO BE DONE HERE
*
*
*  PULL THE PACKED PAGE HEADER INFORMATION
*
      PGETYP=PULFLD(20,2,PGEBUF(1))
      IF(PGETYP.NE.1)GOTO 30
      PGENUM=PULFLD(0,20,PGEBUF(1))
      SPAVBL=PULFLD(23,9,PGEBUF(1))
      IF(ARACHK(CAREAI))SPAVBL=SPAVBL+1
      WRDCNT=512-SPAVBL
      RETURN
20    CONTINUE
      EOFFLG=.TRUE.
      RETURN
      END
      FUNCTION BLDREF(REFARA,REFPGE,REFLIN)
************************************************************************
*                                                                      *
*            FUNCTION BLDREF                         @1978 11 01       *
*                                                                      *
*     USES THE VALUES REFARA,REFPGE,REFLIN TO BUILD A 4-BYTE REFCODE.  *
*     IF REFCODES HAVE 3 BYTES THEN THE FIRST BYTE OF THE RESULTING    *
*     REFCODE IS ONE.                                                  *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER BLDREF,REFARA,REFPGE,REFLIN,ARASUB,REFCDE,LINBIT,FNDARA
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            BLDREF   INTEGER     RESULT OF THIS ROUTINE               *
*            REFARA   INTEGER     AREA FOR REFCODE TO BE BUILT         *
*            REFPGE   INTEGER     PAGE FOR REFCODE                     *
*            REFLIN   INTEGER     LINE FOR REFCODE                     *
*            ARASUB   INTEGER     INDEX NUMBER OF REFARA               *
*            REFCDE   INTEGER     SCRATCH REFCODE LOCATION             *
*            LINBIT   INTEGER     NUMBER OF BITS FOR LINE NUMBERS      *
*                                 IN REFARA                            *
*            FNDARA   FUNCTION    RETURNS THE INDEX OF AN AREA         *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN01
      REFCDE=0
      ARASUB=FNDARA(REFARA)
      IF(ARASUB.EQ.0)GOTO 20
      IF(ARACNT.EQ.1)REFARA=AREA(1)
      CALL PUTFLD(REFCDE,0,8,REFARA)
      LINBIT=ARALSZ(ARASUB)
      CALL PUTFLD(REFCDE,32-LINBIT,LINBIT,REFLIN)
      CALL PUTFLD(REFCDE,8,24-LINBIT,REFPGE)
20    CONTINUE
      BLDREF=REFCDE
      RETURN
      END
      SUBROUTINE GENREC(ERRCD)
*                                                                      *
*            SUBROUTINE GENREC                       @1978 11 01       *
*                                                                      *
*     REMOVES INFORMATION FROM THE CURRENT RECORD IN THE CURRENT       *
*     DATABASE PAGE AND PLACES IT INTO THE EG AND PT FILE              *
*     RECORD BLOCKS, /EGREC/ AND /PTREC/ RESPECTIVLEY.                 *
*     CALLS THE ROUTINE TO PUT THE RECORDS INTO THEIR CORRESPONDING    *
*     OUTPUT BLOCKING BUFFERS.                                         *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,DEFPTR,INDEX0,SETIND,PULPTR
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            DEFPTR   INTEGER     INDEX FOR A SET POINTER DEFINITION   *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            SETIND   INTEGER     TEMP SET INDEX                       *
*            PULPTR   FUNCTION    PULLS AN EDMS POINTER FROM THE       *
*                                 CURRENT RECORD AT THE SPECIFIED      *
*                                 POSITION                             *
************************************************************************
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN02
*
*  PLACE REFCODE, GROUP INDEX IN BOTH EG AND PT RECORDS
*
      EGREF=REFCDE(LINSUB)
      PTREF=REFCDE(LINSUB)
      EGGRP=GRPSUB(LINSUB)
      PTGRP=GRPSUB(LINSUB)
      EGDEL=DELIND(LINSUB)
*
*  SCAN THROUGH ALL SETS INVOLVED
*  WITH THIS GROUP
*
      DO 10 INDEX0=1,SETLISCT(EGGRP)
      SETIND=SETLIST(EGGRP,INDEX0)
      DEFPTR=TPYLNK(SETIND,EGGRP)
*
*  PUT SET INDEX IN BOTH EG AND PT RECORDS
*
      EGSET=SETIND
      PTSET=EGSET
*
*  COPY THE PRIOR POINTER TO THE EG RECORD
*
      EGPRI=PULPTR(DEFPTR,2)
*
*  COPY THE NEXT POINTER TO THE PT RECORD
*
      PTNXT=PULPTR(DEFPTR,1)
*
*  CHECK THE OWNER GROUP OF THIS SET. IF THIS RECORD IS AN OWNER
*  THEN ITS OWNER POINTER IS ITS REFCODE.
*
      IF(GRPNBR(LINSUB).NE.SETOWN(SETIND))GOTO 20
      EGOWN=REFCDE(LINSUB)
      PTOWN=REFCDE(LINSUB)
      GOTO 30
*
*  NOT AN OWNER GROUP, PUT THE SET OWNER POINTER IN BOTH
*  EG AND PT RECORDS
*
20    CONTINUE
      EGOWN=PULPTR(DEFPTR,3)
      PTOWN=EGOWN
*
*  WRITE THE EG AND PT RECORDS
*
30    CONTINUE
      CALL WREGPT(ERRCD)
      IF(ERRCD.NE.0)GOTO 40
10    CONTINUE
      RETURN
40    CONTINUE
      WRITE(UERROR,1000)
1000  FORMAT(' ERRORED GENERATING EG,PT RECORDS')
      RETURN
      END
      SUBROUTINE WREGPT(ERRCD)
************************************************************************
*            SUBROUTINE WREGPT                       @1978 11 01       *
*                                                                      *
*     WRITES CONTENTS OF /EGREC/ INTO EG BLOCKING BUFFER IN /EGBLK/    *
*     WRITES CONTENTS OF /PTREC/ INTO PT BLOCKING BUFFER IN /PTBLK/    *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*                                                                      *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN02
      ERRCD=0
      EGBUF(EGBPTR+1)=EGREF
      EGBUF(EGBPTR+2)=EGGRP
      EGBUF(EGBPTR+3)=EGSET
      EGBUF(EGBPTR+4)=EGPRI
      EGBUF(EGBPTR+5)=EGOWN
      EGBUF(EGBPTR+6)=EGDEL
      EGBPTR=EGBPTR+6
      IF(EGBPTR.EQ.EGBSIZ)CALL WREGBF(ERRCD)
      IF(ERRCD.NE.0)GOTO 10
      PTBUF(PTBPTR+1)=PTREF
      PTBUF(PTBPTR+2)=PTGRP
      PTBUF(PTBPTR+3)=PTSET
      PTBUF(PTBPTR+4)=PTNXT
      PTBUF(PTBPTR+5)=PTOWN
      PTBPTR=PTBPTR+5
      IF(PTBPTR.EQ.PTBSIZ)CALL WRPTBF(ERRCD)
      IF(ERRCD.NE.0)GOTO 10
      OFRCNT=OFRCNT+1
      RETURN
10    CONTINUE
      RETURN
      END
      SUBROUTINE WREGBF(ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE WREGBF                       @1978 11 01       *
*                                                                      *
*     WRITES OUT THE EG FILE BLOCKING BUFFER TO UEGFIL.                *
*     RESETS THE BUFFER POINTER.                                       *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,WRST
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            WRST     INTEGER     WRITE STATUS RETURNED BY BUFFER OUT  *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN02
      CALL BUFFER OUT(UEGFIL,1,EGBUF,EGBPTR,WRST)
      IF(WRST.NE.2)GOTO 10
      EGBPTR=0
      ERRCD=0
      EGBCNT=EGBCNT+1
      RETURN
10    CONTINUE
      WRITE(UERROR,1000)WRST
      ERRCD=1
      RETURN
      END
      SUBROUTINE WRPTBF(ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE WRPTBF                       @1978 11 01       *
*                                                                      *
*     WRITES OUT THE PT FILE BLOCKING BUFFER TO UPTFIL.                *
*     RESETS THE BUFFER POINTER.                                       *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,WRST
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            WRST     INTEGER     WRITE STATUS RETURNED BY BUFFER OUT  *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN02
      CALL BUFFER OUT(UPTFIL,1,PTBUF,PTBPTR,WRST)
      IF(WRST.NE.2)GOTO 10
      PTBPTR=0
      ERRCD=0
      PTBCNT=PTBCNT+1
      RETURN
10    CONTINUE
      WRITE(UERROR,1000)WRST
1000  FORMAT(' BUFFER OUT ERROR, CODE=',I,' ON PT FILE')
      ERRCD=1
      RETURN
      END
      FUNCTION PULPTR(PTRDEF,PTRTYP)
************************************************************************
*                                                                      *
*            FUNCTION PULPTR                         @1979 03 15       *
*                                                                      *
*     RETURNS AS A RESULT THE 3 OR 4 BYTE REFCODE AT THE SPECIFIED     *
*     POSITION OF THE CURRENT RECORD.                                  *
*     IF THE POSITION IS ZERO, THEN ZERO IS THE RESULT.                *
*     IF THE POSITION IS NONZERO, THE RESULT IS ZERO, AND THE SET      *
*     MEMBER IS MANUAL OR OPTIONAL AUTOMATIC, THEN THE CURRENT         *
*     REFCODE IS RETURNED AS THE RESULT.  THIS CORRECTS THE FACT       *
*     THAT MANUALLY DELINKED RECORDS ARE ASSIGNED ZERO-VALUE REFCODES  *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER PULPTR,PTRPOS,INDEX0,PTRBYT,TEMPTR,BYTDSP,WRDDSP,
     @PTRDEF,PTRTYP,PULFLD
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            PULPTR   INTEGER     RESULT OF THIS ROUTINE               *
*            PTRPOS   INTEGER     BYTE POSITION OF START OF REFCODE    *
*                                 FROM START OF RECORD                 *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            PTRBYT   INTEGER     SCRATCH FOR BYTES IN POINTER         *
*            BYTDSP   INTEGER     BYTE DISPLACMENT TO POINTER          *
*            WRDDSP   INTEGER     WORD DISPLACMENT TO POINTER          *
*            PTRDEF   INTEGER     INDEX INTO POINTER DEFINITION TABLES *
*            PTRTYP   INTEGER     CODE FOR TYPE OF POINTER TO PULL     *
*            PULFLD   FUNCTION    PULLS A FIELD FROM A WORD            *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN02
      PTRPOS=SETPTR(PTRDEF,PTRTYP)
      TEMPTR=0
      IF(PTRPOS.EQ.0)GOTO 20
*
*  THE BYTES ARE MOVED INTO TEMPTR IN A LAST BYTE FIRST ORDER
*
      DO 10 INDEX0=1,PTRSIZ
      BYTDSP=PTRPOS+PTRSIZ-INDEX0
      WRDDSP=BYTDSP/4
      BYTDSP=BYTDSP-4*WRDDSP
      PTRBYT=PULFLD(8*BYTDSP,8,PGEBUF(RECHDR(LINSUB)+WRDDSP))
      CALL PUTFLD(TEMPTR,8*(4-INDEX0),8,PTRBYT)
10    CONTINUE
      IF(TEMPTR.EQ.0)GOTO 30
*
*  IF THE POINTER SIZE IS THREE BYTES, THEN PUT THE AREA
*  NUMBER INTO THE FIRST BYTE OF THE REFCODE
*
      IF(PTRSIZ.EQ.3)CALL PUTFLD(TEMPTR,0,8,AREA(1))
      GOTO 20
*
*  CHECK TO SEE IF WE FUDGE THE POINTER
*
30    CONTINUE
      IF(GRPINM(PTRDEF))PULPTR=EGREF;RETURN
*
*  STORE THE RESULT AND GO HOME
*
20    CONTINUE
      PULPTR=TEMPTR
      RETURN
      END
