Retro1.org codex

PRGM SSVAL;
 
# TITLE SSVAL - SFM VALIDATE PROGRAM.                                 #
 
      BEGIN  # SSVAL #
 
#
***** SSVAL - M860 CATALOG VALIDATION UTILITY.
*
*     THE FUNCTION OF *SSVAL* IS TO EXAMINE THE SFM CATALOG AND
*     THE PERMANENT FILE CATALOG FOR THE SPECIFIED FAMILY, OPTIONALLY
*     EXAMINE SPECIFIED SMMAP FILES, AND ISSUE A REPORT DETAILING
*     ANY IRREGULARITIES OR DISCREPANCIES FOUND.  A COUNT OF THE
*     NUMBER OF VALIDATION ERRORS DETECTED, IF ANY, IS PLACED IN
*     THE DAYFILE.  IF SELECTED, *SSVAL* WILL RELEASE SFM SPACE
*     FOR PURGED FILES.  WHEN ERROR CONDITIONS ARE FOUND, *SSVAL*
*     WILL OPTIONALLY SET FLAGS IN AFFECTED ENTRIES OF THESE FILES
*     TO PROTECT A PERMANENT FILE FROM BEING SUBJECT TO BEING
*     LOST AND TO PERMIT THE SITE TO RECOVER FROM THE ERROR VIA
*     THE *SSDEBUG* UTILITY.
*
*     RUN TIME PARAMETERS ALLOW SELECTED SUBFAMILIES OR ALL
*     SUBFAMILIES AND SELECTED SUBCATALOGS OR ALL SUBCATALOGS
*     TO BE ANALYZED.
*
*     THERE ARE TWO TYPES OF VALIDATION RUNS.  THEY ARE -
*      1) TO VALIDATE THE "LIVE" CATALOGS TO DETECT ERRORS AND
          ALLOW REPAIR OF THE CATALOGS.  REPAIR REFERS TO THE
          PROCESS OF SETTING FLAGS WHICH, DEPENDING ON THE FLAG SET
          MAY OR MAY NOT CORRECT THE PROBLEM.
*      2) TO VALIDATE THE COPIES OF THE CATALOGS FROM THE RELEASE
*         DATA FILE TO ALLOW RELEASE OF THE "FREE SPACE" IN THE
*         SFM CATALOG FOR FILES THAT WERE PURGED BY THE USER.
*
*     THE REQUIREMENTS AND RESULTS OF THESE RUNS ARE -
*
*       FOR TYPE 1 -
*         . THE SFM CATALOG PERMANENT FILE MUST BE ATTACHABLE.
*         . THE PERMANENT FILE CATALOG MUST BE ACCESSIBLE.
*         . THE SMMAP FILE MUST BE ATTACHABLE ( IF SELECTED ).
*         . THE CATALOGS ARE EXAMINED FOR VALIDATION ERRORS.
*         . THE VALIDATION REPORT IS ISSUED.
*         . THE CATALOGS ARE REPAIRED FOR ERRORS DETECTED TO
*           ALLOW CORRECTIVE ACTION.
*
*       FOR TYPE 2 -
*         . NO LIVE CATALOGS ARE USED.
*         . NO VALIDATION OF THE SMMAP FILE OCCURS.
*         . COPIES OF THE SFM CATALOG AND THE *PFC* ARE
*            EXAMINED FOR VALIDATION ERRORS.
*         . THE VALIDATION REPORT IS ISSUED.
*         . THE "FREE SPACE" IN THE SFM CATALOG IS RELEASED.  THIS
            CONSEQUENTLY RELEASES SPACE IN THE APPROPRIATE
            CARTRIDGE(S).
*
*     THE REPAIR/RELEASE FUNCTION OF *SSVAL* CANNOT OCCUR IF THE
*     M860 *EXEC* SUBSYSTEM IS NOT RUNNING.
*
 
 
 
 
***   *SSVAL* IS THE M860 UTILITY THAT VALIDATES THE SFM CATALOG,
*     PERMANENT FILE CATALOG (*PFC*) AND THE SMMAP FILE, REPAIRS
*     THE CATALOGS AND RELEASES SPACE IN THE SFM CATALOG FOR PURGED
*     USER FILES.
*
 
***   INPUT DATA IS FROM THE SFM CATALOG FILE AND THE PERMANENT
*     FILE CATALOG FOR A SINGLE FAMILY.  THESE TWO INPUT FILES MAY
*     EITHER BE FROM THEIR PERMANENT LOCATION ON THE FAMILY
*     PACKS ("LIVE") OR FROM THE RELEASE DATA FILE (*RDF*)
*     PRODUCED BY THE *PFDUMP* UTILITY.  *SSVAL* WILL PRODUCE A *PFC
*     EXTRACT FILE* FROM EITHER OF THE ABOVE SOURCES.
*
*     THE SMMAP FILE IS AN INPUT IF SPECIFIED BY AN OPTION ON
*     THE CONTROL CARD.  IT IS ACCESSED ONLY FROM ITS PERMANENT
*     LOCATION ON THE SYSTEM DEFAULT FAMILY.
*
*     SFM CATALOG FILE - CONTAINS THE CONTROL INFORMATION ABOUT
*         THE FILES ON THE MSF.  THE FILE AND CARTRIDGE TABLE (*FCT*)
*         PORTION OF THE CATALOG CONTAINS THE ALLOCATION AND STATUS
*         INFORMATION FOR EACH CARTRIDGE.  THE *FCT*
*         IS EXAMINED FOR IRREGULARITIES AND ERRORS.
*
*     PERMANENT FILE CATALOG - CONTAINS CONTROL INFORMATION ABOUT
*         USER PERMANENT FILES RESIDING ON THE MSF.  THE ALTERNATE
*         STORAGE ALLOCATION FIELD (*ASA*) CONTAINS THE POINTER
*         SPECIFIYING THE *SM* INDEX, *FCT* ORDINAL.
*
*     SMMAP FILE - CONTAINS CONTROL INFORMATION ABOUT ALL CUBES
*         AND CARTRIDGES IN A GIVEN SM.
*
*     RDF FILE - (RELEASE DATA FILE) CONTAINS A HEADER, *PFC* EXTRACT
*         RECORDS, AND COPIES OF SFM CATALOGS.  IT IS PRODUCED BY
*         *PFDUMP*.  THE DATE AND TIME WHEN THE FILE WAS CREATED IS
*         RECORDED IN THE HEADER.  THE RDF FILE IS USED FOR BACKUP
*         PURPOSES ONLY.  A DESCRIPTION OF THE FIELDS IN THE RDF FILE
*         MAY BE FOUND IN *COMSPFM*.
*
*
 
***   CONTROL CARD CALL.
*
*     SSVAL(P1,P2,...,PN)
*
*       PARAMETER                DESCRIPTION
*       ---------                -----------
*
*       L                  LISTABLE OUTPUT ON FILE *OUTPUT*.
*       L = *LFN*          LISTABLE OUTPUT ON FILE *LFN*.
*       L = 0              NO OUTPUT FILE GENERATED.
*       L OMITTED          SAME AS L.
*
*       RF                 RELEASE DATA FILE ON LOCAL FILE *ZZZZRDF*.
*       RF = *LFN*         RELEASE DATA FILE ON FILE *LFN*.
*       RF OMITTED         USE THE CURRENT VERSION OF THE SFM CATALOGS
*                          FOR ANALYSIS.
*
*       FM                 USE DEFAULT FAMILY.  NOT PERMITTED IF *RF*
*                          IS SPECIFIED.
*       FM=FAMILY          FAMILY TO BE ANALYZED.  NOT PERMITTED IF
*                          *RF* IS SPECIFIED.
*       FM OMITTED         SAME AS *FM* IF *RF* IS NOT SPECIFIED.  USE
*                          THE FAMILY ON THE RELEASE DATA FILE IF *RF*
*                          IS SPECIFIED.
*
*       SB                 ALL SUBFAMILIES ARE TO BE PROCESSED.
*       SB = CHARS         SELECT UP TO EIGHT SUBFAMILIES.  THERE
*                          ARE EIGHT POSSIBLE SUBFAMILIES NUMBERED FROM
*                          0 THROUGH 7 (E.G. SB=723 SELECTS SUBFAMILIES
*                          2,3,AND 7).
*       SB OMITTED         SAME AS *SB*.
*
*       SM                 ALL *SM-S* PROCESSED.
*       SM = CHARS         SELECT UP TO EIGHT *SM*-S INDICATED
*                          BY THE LETTERS A-H (E.G. SM=ACHG SELECTS
*                          *SM-S* A, C, AND H).
*       SM OMITTED         SAME AS *SM*.
*
*       AM                 ANALYZE THE SFM SMMAP.  THIS OPTION MAY
*                          ONLY BE USED IF *RF* IS NOT SPECIFIED.
*                          *SSVAL* WILL ONLY EXAMINE A PARTICULAR
*                          SMMAP IF THE SFM CATALOG HAS A SUBCATALOG
*                          FOR THE CORRESPONDING *SM* AND IS THAT
*                          *SM* WAS SELECTED BY THE *CS* PARAMETER.
*       AM OMITTED         DO NOT ANALYZE THE SFM SMMAP.
*
*       FX                 *PFC* AND SFM CATALOGS WILL NOT BE
*                          AUTOMATICALLY FLAGGED OR FIXED AND RELEASE
*                          PROCESSING WILL NOT BE PERFORMED IF THERE
*                          ARE ANY ERRORS (SAME AS FX=0).
*       FX = N             *PFC* AND SFM CATALOGS WILL ONLY BE
*                          AUTOMATICALLY FIXED OR RELEASE PROCESSING
*                          WILL BE PERFORMED ONLY IF THE TOTAL ERROR
*                          COUNT IS LESS THAN OR EQUAL TO N.
*       FX OMITTED         SAME AS *FX*.
*
*       RL                 RELEASE PROCESSING IS TO BE PERFORMED.
*                          THIS OPTION MAY ONLY BE USED IF *RF*
*                          IS ALSO SELECTED.
*       RL OMITTED         NO RELEASE PROCESSING WILL BE PERFORMED.
*
*       ST                 FILES ARE INDICATED AS SCATTERED IF THEY
*                          SPREAD ACROSS MORE THAN THE MINIMUM NUMBER
*                          OF CARTRIDGES NEEDED TO CONTAIN THEM.
*       ST = N             FILES ARE INDICATED AS SCATTERED IF THEY
*                          SPREAD ACROSS N MORE CARTRIDGES THAN THE
*                          MINIMUM NUMBER NEEDED TO CONTAIN THEM.
*       ST OMITTED         SAME AS *ST*.
*
*
 
 
 
***   THE VALIDATION PROCESS EXAMINES THE ALTERNATE STORAGE AND
*     PERMANENT FILE CATALOGS AND REPORTS VALIDATION ERRORS DETECTED.
*
*     THE CATALOG ENTRIES ARE VALIDATED AS FOLLOWS.
*       . ALL *PFC* ENTRIES FOR USER FILES THAT RESIDE ON MSF.
*         - THE *ASA* FIELD.
*           * ASA NOT HEAD OF CHAIN.
*           * ASA OUT OF RANGE.
*           * INVALID *SM* IN ASA.
*           * MULTIPLE *PFC* ENTRIES OWN THE SFM FILE.
*         - THE READ DATA ERROR FLAG.
*           * READ ERROR FLAG SET IN *PFC* ENTRY.
*       . ALL *FCT* ENTRIES IN THE SFM CATALOG.
*         - THE CARTRIDGE STATUS (INHIBIT, LOST, EXCESSIVE
*           WRITE PARITY ERROR, START OF FRAGMENT, CONFLICT, SMMAP
*           ERROR,CSN AND Y AND Z COORDINATES).
*           * *FCT* ENTRIES CONTAIN THE FOLLOWING PROBLEMS -
*             - INHIBIT ALLOCATION FLAG SET.
*             - FROZEN CHAIN FLAG SET.
*             - EXCESSIVE WRITE PARITY ERRORS FLAG SET.
*             - START OF FRAGMENT FLAG SET.
*             - AU CONFLICT FLAG SET.
*             - LOST CARTRIDGE FLAG SET.
*         - THE AU CHAIN INFORMATION (CHAIN CONTROL, OFF CARTRIDGE
*           LINK FLAG, OFF CARTRIDGE LINKS).
*           * CHAINS INTERSECT OR ARE ILL-FORMED.
*           * FRAGMENTS DETECTED.
*           * SCATTERED FILE DETECTED.
*           * NO VALID SMMAP ENTRY FOR THE FCT.
*
*       . ALL SMMAP ENTRIES ASSIGNED TO THE SUBFAMILY.
*         - THE VSN, FAMILY, SUBFAMILY, *FCT* ORDINAL FIELDS.
*       . SMMAP ENTRY ALLOCATED TO THE SUBFAMILY THAT HAS NO
*         VALID *FCT* ENTRY IN THE SFM CATALOG.
*
 
***   THE RESULTS OF RUNNING *SSVAL* ARE:
*     - THE VALIDATION REPORT.
*     - THE RELEASE OF FREE SFM SPACE IN THE SFM CATALOG.
*     - THE REPAIRS OF THE CATALOGS FOR VALIDATION ERRORS DETECTED.
*
*     FREE SPACE IN THE SFM CATALOG IS RELEASED IF THE RF AND
*     RL CONTROL CARD PARAMETERS WERE SPECIFIED AND IF THE
*     TOTAL VALIDATION ERRORS DETECTED WERE LESS THAT THE
*     THRESHOLD SET BY THE FX CONTROL CARD PARAMETER.  IN ADDITION,
*     THE RELEASE FOR A SPECIFIC SUBFAMILY AND *SM* OCCURS ONLY
*     IF THE RDF FILE DATE AND TIME IS MORE RECENT THAN THE
*     LAST PURGE DATE AND TIME RECORDED IN THE PREAMBLE OF THE
*     SFM CATALOG.
*
*     REPAIRS TO THE CATALOGS OCCUR ONLY IF THE FM CONTROL CARD
*     PARAMETER IS ACTIVE AND THE TOTAL VALIDATION ERRORS ARE
*     LESS THAN THE THRESHOLD SET BY THE FX CONTROL CARD PARAMETER.
*
*     *PFC* ENTRIES CAN ONLY BE REPAIRED IF THE FILE IS DISK RESIDENT.
*       - THE *ASA* IS CLEARED IN THE *PFC* ENTRY TO PREVENT THE
*         RELEASE OF THE DISK SPACE.
*     REPAIRS TO THE SFM CATALOG OCCUR IF ERRORS ARE DETECTED IN
*     *FCT* ENTRIES.
*       - THE FOLLOWING FLAGS ARE SET IN THE SFM CATALOG *FCT* ENTRY.
*         . THE FROZEN FLAG IS SET TO PREVENT AUTOMATIC RELEASE OF THE
*           SFM FILE SPACE AND ALLOW INSPECTION OF THE SFM DATA.
*         . THE START OF FRAGMENT FLAG IS SET IF A FRAGMENT WAS
*           DETECTED.
*         . THE SMMAP ERROR FLAG IS SET IF THE *FCT* HAS NO SMMAP
*           ENTRY.
*         . THE INHIBIT FLAG IS SET IF THE SMMAP ERROR OCCURRED.
*     REPAIR TO THE SMMAP FILE OCCURS FOR ERRORS DETECTED IN THE
*     SMMAP-*FCT* LINKAGE.
*         . THE ERROR FLAG IN THE SMMAP ENTRY IS SET.
*
*     THE VALIDATION REPORT CONTAINS INFORMATIONAL AND ERROR LINES
*     DESCRIBING WHAT WAS VALIDATED AND WHAT WAS FOUND TO BE IN ERROR.
*
*     COLUMN 0 IS RESERVED FOR THE CARRIAGE CONTROL CHARACTER.
*
*     THE TITLE, INFORMATIONAL AND HEADING LINES START IN COLUMN  4.
*
*     THE DETAIL LINES START IN COLUMN 7 OR BEYOND.
*
*       LINE           -             GENERAL
*       TYPE           -             FORMAT
*       ----           -             ------
*
*     TITLE            -    SSVAL - VALIDATION REPORT     ...VER 1.0
*     SUB-TITLE        -            FAMILY = NAME
*
*     PRESET           -                (CONTROL CARD IMAGE)
*       DETAIL         -                (LIST OF) KEYWORD = VALUE.
*
*     RDF DETAIL       -    RDF FILE FAMILY = NAME
*                      -    RDF FILE BUDT   = DATE-TIME
*
*     PRESET           -    *** PF = NAME          INVALID SM IN PFC
*       ERRORS         -        UI = VALUE
*
*     SUBCATALOG       -    SUBFAMILY = N  *SM* = X    "GOOD"
*       HEADINGS       -                              "INTERSECTIONS"
*                      -                              "PROBLEMS"
*
*     SUB-HEADING      -                    -HEAD OF CHAINS-
*       INTERSECTIONS  -                 FCTORD-STRM   FCTORD-STRM
*
*     INTERSECTIONS    -                 (CHAIN-ID)     (CHAIN-ID)
*       DETAIL         -
*
*     SUB-HEADING      -     ERR   IDENTIFICATION     -CHAIN-    ERROR
*       PROBLEMS       -     TYP                  FCT-STM-A/U-H-E
*
*     PROBLEM          -      4    PF=NAME
*       DETAIL         -           UI=VALUE
*                      -           BU=DATE-TIME
*                      -           DI=N/Y           (CHAIN-ID)   TEXT
*                                                   (CHAIN-ID)  (TEXT)
*                                                                TEXT
*
*     SUMMARY          -    FREE M860 FILE    = NNN
*                      -    FREE M860 AU-S = NNNN
*                      -    TOTAL VALIDATION ERRORS = NNN
*
*     MISCELLANEOUS    -    ***CONNECT TO EXEC FAILED
*                      -    CATALOGS NOT MODIFIED
*                      -    CATALOGS MODIFIED
*                      -    FREE FILES RELEASED
*
*
*     THE INTERSECTIONS REPORT SECTION IS ISSUED FOR THE SUBCATALOG
*     WHEN INTERSECTIONS ARE DETECTED.
*
*     THE PROBLEM REPORT SECTION IS ISSUED AT THE END OF EACH
*     SUBCATALOG-S VALIDATION.
*
*     ENOUGH IDENTIFICATION IS GIVEN TO ALLOW THE ANALYST TO LOCATE THE
*     ENTRY(S) RELATING TO THE PROBLEM IN THE CATALOGS: SFM CATALOG,
*     *PFC* OR SMMAP.
*
*     ERROR TYPE VALUES IN THE PROBLEM REPORT SECTION ARE -
*         1 - *FCT* ENTRY WITH NO VALID SMMAP ENTRY.
*         2 - SMMAP ENTRY WITH NO VALID *FCT* ENTRY.
*         3 - *PFC* ENTRY WITH INVALID ASA.
*         4 - *PFC* ENTRY WITH PROBLEMS.
*         5 - ORPHANS WITH PROBLEMS.
*         6 - CHAIN FRAGMENTS.
*         7 - UNALLOCATED SFM ENTRIES WITH PROBLEMS.
*
 
 
***   DAYFILE MESSAGES.
*
*      * SSVAL COMPLETED.*
*      * SSVAL ABORTED.*
*      * FREE FILES RELEASED.*
*      * CATALOGS MODIFIED.*
*      * CATALOGS NOT MODIFIED.*
*      * TOTAL VALIDATION ERRORS = NN.*
*      * VALIDATING SB=N SM=X.*
*      * CONTROL CARD SYNTAX ERROR.*
*      * INVALID CS PARAMETER.*
*      * INVALID FX PARAMETER.*
*      * INVALID SB PARAMETER.*
*      * INVALID ST PARAMETER.*
*      * ILLEGAL - L AND RF PARAMETER.*
*      * ILLEGAL - RL AND NO RF PARAMETER.*
*      * ILLEGAL - RF AND FM PARAMETER.*
*      * ILLEGAL - RF AND AM PARAMETER.*
*      * SSVAL - MUST BE SYSTEM ORIGIN.*
*      * RDF FILE ERROR - MISSING HEADER.*
*      * RDF FILE ERROR - BAD RECORD LENGTH.*
*      * RDF FILE ERROR - UNIDENTIFIED DATA.*
*      * SFM CATALOG OPEN ERROR.*
*      * SFM CATALOG READ ERROR.*
*      * SMMAP OPEN ERROR.*
*      * SMMAP READ ERROR.*
*      * REQUIRED FL EXCEEDS JOB MAX.*
*      * CONNECT TO EXEC FAILED.*
*      * UCP CALL ERROR.*
*      * FAMILY NOT FOUND IN SYSTEM.*
*      * ERROR READING *PFC*.*
*      * SSVAL ABNORMAL* NAME.*
*
 
 
***   OPERATOR MESSAGES.
*
*      * WAITING FOR FILE FILENAME.*
*      * WAITING FOR EXEC.*
*      * VALIDATING SB=N SM=X.*
*
 
***   SSVAL.
*
*     *SSVAL* IS THE M860 UTILITY PROGRAM THAT VALIDATES DATA IN THE
*     SFM CATALOG, THE PERMANENT FILE CATALOG (PFC) AND THE SMMAP
*     FILE.  IT CAN ALSO REPAIR THE CATALOGS FOR VALIDATION
*     ERRORS DETECTED AND RELEASE FREE SPACE IN THE SFM CATALOG FOR
*     PURGED USER FILES.
*
*     SSVAL(P1,P2,...,PN)
*
*     PRGM SSVAL
*
*     MESSAGES  * CONNECT TO EXEC FAILED.*
*               * SSVAL COMPLETED.*
*
*     NOTES    *SSVAL* -
*              . CALLS VLPRSET TO INITIALIZE FILES AND PARAMETERS.
*              . CONNECTS TO M860 *EXEC*.
*              . CALLS VLSUBFM FOR EACH SUBFAMILY TO VALIDATE.
*              . CALLS VLFIX TO PERFORM REPAIR/RELEASE PROCESSING
*                ON THE CATALOGS.
*              . DISCONNECTS AND CLOSES.
*
 
**********
 
**    METHOD.  OR  METHODS....
*
*     A NUMBER OF LOCAL FILES ARE USED TO RETAIN INFORMATION
*     THROUGHOUT THE VALIDATION PROCESS -
*
*      . *PFC* EXTRACT FILES - CONTAIN EXTRACTS FROM THE LIVE
*            *PFC* OR FROM THE RDF FILE.  THERE IS A SEPARATE
*            FILE FOR EACH SUBFAMILY.
*
*      . PROBLEM FILE - CONTAINS ENTRIES FOR VALIDATION
*            ERRORS DETECTED.
*
*      . FIXIT FILE - CONTAINS ENTRIES FOR ALL REPAIRS AND
*            RELEASES THAT MAY BE PERFORMED.
*
*      . ZZZVALX FILES - CONTAIN COPIES OF THE SFM CATALOGS,
*            FROM THE RDF FILE.  THERE IS A SEPARATE FILE
*            FOR EACH SUBFAMILY.
*
*     A VALIDATION TABLE (*VT*) IS USED TO CONTAIN AND EXAMINE
*     THE *FCT* DATA FOR A SUBCATALOG IN THE SFM CATALOG.  THE
*     *VT* HAS A 1 WORD ENTRY.
*
*     EACH WORD (REPRESENTING ONE AU IN THE *FCT*) CONTAINS
*     STATUS AND LINKAGE INFORMATION ABOUT THE AU -
*         . ALLOCATED OR NOT.
*         . HEAD OF CHAIN AND/OR END OF CHAIN
*         . *PFC* OWNER FLAG
*         . VALIDATION ERROR FLAGS.
*         . A LINK TO THE NEXT AU IN THE CHAIN.
*
*     VALIDATION ERROR FLAGS ARE ASSIGNED PROBLEM TYPES (1,2, OR 4)
*     THAT REFLECT THE SUBSEQUENT REPORT AND REPAIR PROCESSING
*     THAT SHOULD OCCUR -
*         TYPE 1 - REPORT THE PROBLEM AND DO NOT REPAIR.
*         TYPE 2 - REPORT THE PROBLEM.  REPAIR ONLY IF THERE
*                  IS AN ASSOCIATED *PFC* ENTRY.
*         TYPE 4 - REPORT THE PROBLEM AND REPAIR THE CATALOG(S).
*
*     THE *VT* IS USED AS A FAST METHOD TO FOLLOW CHAINS TO
*     ENSURE THAT THEY ARE VALID.  ERRORS ARE-
*         . INTERSECTING CHAINS.
*         . ILL-FORMED CHAINS.
*
*     AS THE CHAIN IS FOLLOWED, EACH ENTRY IS MARKED BY SETTING
*     THE POINTER FIELD TO THE HEAD OF CHAIN ENTRY.
*
**    GENERAL RULES.
*
*     *SSVAL* ALWAYS ISSUES A SUBSYSTEM REQUEST USING THE
*     SUBSYSTEM ID FOR THE M860 EXEC AND PARAMETERS FOR A
*     "CONNECT".  IF THE M860 EXEC IS NOT PRESENT OR IF THE
*     M860 EXEC RETURNS AN ERROR STATUS, *SSVAL* ISSUES A
*     MESSAGE "CONNECT TO EXEC FAILED" AND CONTINUES.  BUT
*     NO FURTHER SUBSYSTEM REQUESTS ARE MADE.  THEREFORE, NO
*     REPAIR/RELEASE PROCESSING CAN OCCUR.  SSVAL CONTINUES
*     IN THIS "LIMITED" MODE TO PRODUCE THE VALIDATION REPORT.
*
*     THE CATALOGS ARE ATTACHED IN READ MODE.  THIS PROVIDES AN
*     INTERLOCK TO ENSURE THAT NO ONE IS MODIFIYING THE DATA
*     DURING VALIDATION.
*
*     I/O ERRORS WILL BE DETECTED AND PROCESSED BY *CIO*.
*
**    HEIRARCHY.
*
*     3 MAJOR STEPS -
*
*      . PRESET - PROCESS THE CONTROL CARD PARAMETERS INTO
*                 RUN TIME PARAMETERS.
*               - PROCESS INPUT FILES TO GENERATE WORKING FILES.
*
*      . VALIDATE (THIS STEP REPEATS FOR ALL SELECTED
*              SUBCATALOGS WITHIN SELECTED SUBFAMILIES).
*               - ANALYZES ALL CATALOG DATA AND GENERATES THE
*                 PROBLEM FILE.
*               - EXAMINES ALL PROBLEM FILE ENTRIES AND GENERATES
*                 THE VALIDATION REPORT AND THE FIXIT FILE.
*
*      . FIX    - EXAMINES THE FIXIT FILE ENTRIES AND RELEASES FREE
*                 SPACE IF THIS MODE IS SELECTED.
*               - EXAMINES THE FIXIT FILE ENTRIES AND REPAIRS CATALOG
*                 ENTRIES IF THIS OPTION IS SELECTED.
*
*
*     *SSVAL* MAJOR ROUTINES.
*       1.0  VLPRSET - PRESET PARAMETERS AND FILES.
*            1.1 VLTAB -
*            1.2 VLPFC - READ THE PFC.
*            1.3 VLRDF - READ THE RDF FILE.
*                1.3.1 VLRDF2 - PROCESS THE RDF RECORD.
*
*       2.0  VLSUBFM - SUBFAMILY VALIDATION.
*            2.1 VLBLDVT - BUILD VALIDATION TABLE.
*                2.1.1 VLCMAP - SMMAP LOOKUP.
*            2.2 VLASFM - ANALYZE THE SFM CATALOG.
*                2.2.1 VLNCS - NORMAL CHAIN SCAN.
*                2.2.2 VLCFS - CHAIN FRAGMENT SCAN.
*                2.2.3 VLSMSC - SMMAP SCAN.
*            2.3 VLAPFC - ANALYZE THE *PFC* CATALOG.
*                2.3.1 VLAPFC2 - ANALYZE *PFC* PASS 2.
*            2.4 VLRPT - VALIDATION REPORT.
*                2.4.1 VLRPTL - ISSUE REPORT LINE.
*                2.4.2 VLSCH - SCAN CHAIN FOR REPORT.
*
*       3.0  VLFIX - FIX CATALOGS.
*            3.1 VLFIXP - FIX PFC.
*
 
**    EXTERNAL INTERFACE ROUTINES.
*
*     CATALOG/MAP ACCESS ROUTINES.
*     M860 REPORT FORMATTER.
*     NOS MACROS USING THE SYMPL INTERFACES ON MAC1.
*     SPECIAL ROUTINES ON MAC2.
*      - XARG
*      - CALLSS
*      - CINTLK
*      - GETFAM
*      - RDPFC
*      - SETASA
*      - SETPFP
*      - UATTACH
#
 
                                               CONTROL PRESET;
 
#
****  PROC SSVAL - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC ABORT;                  # CALLS *ABORT* MACRO #
        PROC GETPFP;                 # GET USER INDEX AND FAMILY #
        PROC GETSPS;                 # GET SYSTEM ORIGIN STATUS #
        PROC MEMORY;                 # INTERFACE TO *MEMORY* MACRO #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT
                                       OR RETURN #
        PROC RPCLOSE;                # CLOSES A PRINT FILE #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC VLFIX;                  # FIX CATALOGS #
        PROC VLMSG;                  # ISSUE INFORMATIONAL MESSAGE #
        PROC VLPRSET;                # PRESET PARAMETERS AND FILES #
        PROC VLREQEX;                # REQUEST TO EXEC #
        PROC VLSUBFM;                # SUBFAMILY VALIDATION #
        END
 
#
****  PROC SSVAL - XREF LIST END.
#
 
      DEF RSLEN      #1#;            # RETURN STATUS WORD LENGTH #
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTINGS #
 
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBCPR
*CALL COMBMAP
*CALL COMBMCT
*CALL COMBPFP
*CALL COMTFMT
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLM
*CALL COMTVLV
*CALL COMTVLX
 
 
      ARRAY SCR$FET [0:0] S(SFETL);;  # SCRATCH FET #
      ARRAY SPSSTAT [0:0] S(RSLEN);
        BEGIN
        ITEM SPS$STATUS U(00,48,12);  # RETURN STATUS #
        END
                                               CONTROL EJECT;
 
      GETSPS(SPSSTAT);               # GET SYSTEM ORIGIN STATUS #
      IF SPS$STATUS NQ 0
      THEN
        BEGIN
        VLMSG(VM"NEEDSYOT");         # MUST HAVE SYSTEM PRIVILEGES #
        ABORT;
        END
 
#
*     SAVE THE USER-S CURRENT FAMILY AND USER INDEX IN COMMON.
#
 
      GETPFP(PFP[0]);
      USER$FAM[0] = PFP$FAM[0];
      USER$UI[0] = PFP$UI[0];
 
#
*     GET CURRENT JOB FIELD LENGTH.
#
 
      MEM$MIN = O"50000";            # SAVE PROGRAM SIZE #
      MEM$WDS[0] = MEM$MIN;
      MEMORY("CM",MEMRQST,RCL,NA);   # SET MEMORY #
 
#
*     GET MAXIMUM JOB FIELD LENGTH.
#
 
      MEM$WDS[0] = REQMAXFL;
      MEMORY("CM",MEMRQST,RCL,NA);
      MEM$MAX = MEM$WDS[0];          # SAVE MAXIMUM MEMORY ALLOWED #
 
#
*     PRESET - PROCESS CONTROL CARD AND INITIALIZE FILES.
#
 
      VLPRSET;
 
#
*     CONNECT TO SUBSYSTEM.
#
 
      CONNECTED = TRUE;              # INITIALIZE FOR VLREQEX CALL #
      VLREQEX(TYP"TYP1",REQTYP1"CONNECT");
      IF STAT NQ 0
      THEN                           # CONNECT REQUEST FAILED #
        BEGIN
        VLERROR(VE"NCONNECT",NOABT);  # ISSUE ERROR MESSAGE #
        CONNECTED = FALSE;           # NOT CONNECTED #
        END
 
#
*     VALIDATE ALL SELECTED SUBFAMILIES.  ONLY THOSE SUBFAMILIES
*     SELECTED BY THE CONTROL CARD AND WHO HAVE THE SFM CATALOG FILE
*     AVAILABLE IN THIS RUN ARE VALIDATED.
#
 
      SLOWFOR SBINDX = 0 STEP 1 UNTIL MAXSF
      DO
        BEGIN
        IF (B<SBINDX,1>PAR$SB EQ 1) AND (B<SBINDX,1>SFMCATDEF EQ 1)
          THEN
          BEGIN
          VLSUBFM;                   # VALIDATE SUBFAMILY #
          END
 
        END
 
#
*     RETURN MEMORY USED IN VALIDATION.
#
 
      MEM$WDS[0] = MEM$MIN;
      MEMORY("CM",MEMRQST,RCL,NA);   # REDUCE FL #
 
 
 
#
*     FIX CATALOGS PROCESSING.
#
 
      VLFIX;
 
#
*     CLOSE THE REPORT FILE AND DISCONNECT.
#
 
      RPCLOSE(RPTFADR);
 
      VLREQEX(TYP"TYP1",REQTYP1"DISCONNECT");  # DISCONNECT FROM EXEC #
 
      VLMSG(VM"VLDONE");             # SSVAL COMPLETED #
      IF TOTALERRS - PAR$FX LQ 0
      THEN
        BEGIN
        RESTPFP(PFP$END);
        END
 
      ELSE
        BEGIN
        RESTPFP(PFP$ABORT);
        END
 
 
      STOP;
 
      END  # SSVAL #
 
    TERM
PROC VLAMSF;
# TITLE VLASFM - ANALYZE THE SFM CATALOG.                             #
 
 
      BEGIN  # VLASFM #
 
#
**    VLASFM - ANALYZE THE SFM CATALOG.
*
*     *VLAMSF* CONTROLS THE VALIDATION PROCESS THAT EXAMINES
*     THE SFM CATALOG DATA IN THE *VT* TABLE.
*
*     PROC VLASFM
*
*     ENTRY     (PAR$AM)        - AM CONTROL CARD PARAMETER.
*               (ARRAY VTTABLE) - VALIDATION TABLE ENTRIES.
*
*     EXIT      (VTEN$PROB) - THIS FIELD IN EACH VALIDATION TABLE ENTRY
*                             IS UPDATED TO REFLECT THE TYPE OF
*                             VALIDATION PROBLEMS ENCOUNTERED SO FAR.
*
*     NOTES     *VLAMSF* PROCESSES BY -
*               . CALLING *VLNCS* TO PERFORM THE NORMAL CHAIN SCAN.
*               . CALLING *VLCFS* TO PERFORM THE CHAIN FRAGMENT SCAN.
*               . CALLING *VLSMSC* TO SCAN THE SMMAP.
*               . SCANNING ALL ENTRIES IN THE *VT* TABLE TO UPDATE THE
*                 PROBLEM FIELD IN THE ENTRY AND IN ITS ASSOCIATED HEAD
*                 OF CHAIN ENTRY.
#
 
#
****  PROC VLASFM - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC VLCFS;                  # CHAIN FRAGMENT SCAN #
        PROC VLSMSC;                # *SM* MAP SCAN #
        PROC VLNCS;                  # NORMAL CHAIN SCAN #
        END
 
#
****  PROC VLASFM - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLV
 
 
 
 
      ITEM I          I;             # TEMPORARY VARIABLE #
      ITEM K          I;             # TEMPORARY VARIABLE #
      ITEM PT         U;             # PROBLEM TYPE #
 
                                               CONTROL EJECT;
 
#
*     PERFORM NORMAL CHAIN SCAN.
#
 
      VLNCS;
 
#
*     PERFORM CHAIN FRAGMENT SCAN.
#
 
      VLCFS;
 
#
*     PERFORM SMMAP SCAN IF THE *AM* PARAMETER WAS SPECIFIED.
#
 
 
#
*     SCAN ALL *VT* ENTRIES TO UPDATE THE *VT* PROBLEM FIELD IN THE
*     ENTRY AND IN THE CORRESPONDING HEAD OF CHAIN ENTRY.  THE PROBLEM
*     FIELD IS DEFINED TO BE THE LOGICAL SUM OF ALL THE PROBLEM TYPES
*     FOR ALL THE VALIDATION ERRORS DETECTED FOR THAT ENTRY.  PROBLEM
*     TYPES FOR EACH VALIDATION ERROR ARE DEFINED IN THE *VTPTYPES*
*     ARRAY IN COMTVLV.
#
 
      SLOWFOR I = VTFIRST STEP 1 UNTIL VTLAST
      DO
        BEGIN  # SCAN OF *VT* ENTRIES #
        VTEN$WORD[0] = VT$ITEM[I];   # GET *VT* ENTRY #
 
#
*     SCAN THE ERROR FLAGS IN THE *VT* ENTRY (BITS *VPS* THRU *VPX*).
*     ADD THE PROBLEM TYPE FOR EVERY ACTIVE ERROR FLAG TO THE LOGICAL
*     SUM.
#
 
        PT = 0;
        SLOWFOR K = VPS STEP 1 UNTIL VPX
        DO
          BEGIN
          IF B<K,1>VTEN$WORD[0] EQ 1
          THEN
            BEGIN
            PT = PT LOR VTP$TYP[K];  # OR LOGICAL SUM TOGETHER #
            END
 
          END
 
#
*     LOGICALLY ADD THE COMPUTED PROBLEM TYPES TO THE PROBLEM FIELD IN
*     IN THE *VT* ENTRY.
#
 
        VTEN$PROB[0] = VTEN$PROB[0] LOR PT;
        VT$ITEM[I] = VTEN$WORD[0];   # STORE *VT* ENTRY #
 
#
*     UPDATE *HOC* ENTRY PROBLEM FIELD ( LOGICAL SUM OF MEMBERS ).
#
 
        VTEN$WORD[0] = VT$ITEM[VTEN$POINT[0]];  # GET *HOC* ENTRY #
        VTEN$PROB[0] = VTEN$PROB[0] LOR PT;  # ADD VALUE OF MEMBER #
        VT$ITEM[VTEN$POINT[0]] = VTEN$WORD[0];  # UPDATE *HOC* ENTRY #
        END  # SCAN OF *VT* ENTRIES #
 
      END  # VLASFM #
 
    TERM
PROC VLAPFC(GROUP);
# TITLE VLAPFC - ANALYZE THE *PFC* CATALOG.                           #
 
 
      BEGIN  # VLAPFC #
 
#
**    VLAPFC - ANALYZE THE *PFC* CATALOG DATA.
*
*     *VLAPFC* READ THE *PFC* EXTRACT FILE FOR THE SUBFAMILY
*     AND VALIDATES EACH *PFC* ENTRY FOR THE SELECTED *SM*.
*
*     PROC VLAPFC
*
*     ENTRY     (SMINDX)        - *SM* NUMBER.
*               (PRM$ENTRC)     - COUNT OF *FCT* ENTRIES IN PREAMBLE.
*               (SBINDX)        - SUBFAMILY NUMBER.
*               (ARRAY VTTABLE) - VALIDATION TABLE ENTRIES.
*
*     EXIT      FOR DETECTED ERRORS -
*               . SET *VT* ENTRY ERROR FLAGS AND UPDATE THE
*                 *VTEN$PROB* FIELD.
*               . A PROBLEM FILE RECORD IS WRITTEN (RECORD TYPE
*                 REC"ASA" OR REC"OTHR").
*
*     MESSAGES  * SSVAL ABNORMAL, VLAPFC.*.
*
*     NOTES     *VLAPFC* WILL DETECT THE FOLLOWING ERRORS -
*               . ILLEGAL *ASA* IN THE *PFC* (NO SFM CATALOG ENTRY
*                 FOR THE *ASA* IN THE *VT*).
*               . MULTIPLE OWNERS.
*               . NOT HEAD OF CHAIN.
*               . DATA ERROR FLAG ON IN THE *PFC*.
*               . *PFC* POINTS TO A CHAIN WITH PROBLEMS.
*
*               IF THE MULTIPLE OWNERS COUNTER IS NOT ZERO, *VLAPFC2*
*               IS CALLED TO FIND THE FIRST OWNER.
#
 
#
****  PROC VLAPFC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC MESSAGE;                # MESSAGE TO DAYFILE #
        PROC VLWFIX;                 # WRITE FIXIT FILE RECORD #
        PROC READ;                   # INTERFACE TO *READ* MACRO #
        PROC READW;                  # INTERFACE TO *READW* MACRO #
        PROC REWIND;                 # INTERFACE TO *REWIND* MACRO #
        PROC VLAPFC2;                # ANALYZE *PFC* PASS 2 #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC VLWPROB;                # WRITE PROBLEM FILE RECORD #
        FUNC XCOD C(10);             # BINARY TO DISPLAY #
        PROC ZSETFET;                # INITIALIZES A *FET* FOR *I/O* #
        END
 
#
****  PROC VLAPFC - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBMCT
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLV
 
 
      ITEM GROUP      I;             # GROUP BEING PROCESSED #
      ITEM GMO        I;             # GLOBAL MULTIPLE OWNERS #
      ITEM I          I;             # TEMPORARY VARIABLE #
 
      ARRAY BLDLFN [0:0] S(1);       # BUILD *LFN* #
        BEGIN
        ITEM BLDNAME    C(00,00,07) = [ EXTLFN ];  # NAME OF FILE #
        ITEM BLDLFNX    U(00,36,06);  # SUBFAMILY NUMBER #
        END
 
#
*     THIS ARRAY FOR LINK MESSAGE.
#
 
      ARRAY LINK [0:0] P(3);
        BEGIN                        # LINK MESSAGE #
        ITEM LINK$MG  C(00,00,10) = ["   UI =   "];
        ITEM LINK$NO  C(01,00,10);
        ITEM LINK$Z   U(02,00,60) = [0]; # ZERO BYTE #
        END
 
 
                                               CONTROL EJECT;
 
      P<PREAMBLE> = PRMBADR;
 
      GMO = 0;                       # INITIALIZE MULTIPLE OWNERS
                                       COUNTER #
 
#
*     INITIALIZE THE *PFC* EXTRACT FILE FOR READING.
#
 
      EXTFADR = LOC(EXTRACTFIL);     # FET ADDRESS #
      EXTBADR = LOC(EXTRACBUF);      # BUFFER ADDRESS #
      BLDLFNX = SBINDX + "0";        # APPEND SUBFAMILY TO *LFN* #
      ZSETFET(EXTFADR,BLDLFN,EXTBADR,LEXTBUF,SFETL);
 
      REWIND(EXTRACTFIL,RCL);
      READ(EXTRACTFIL,NRCL);
 
#
*     PROCESS EACH RECORD IN THE *PFC* EXTRACT FILE FOR THE SUBFAMILY.
#
 
      STAT = OK;
      REPEAT WHILE STAT EQ OK
      DO
        BEGIN  # SCAN SUBFAMILY *PFC* ENTRIES #
        READW(EXTRACTFIL,EXTRECORD,RLEXTR,STAT);
 
        IF STAT NQ OK
        THEN                         # DETECTED EOR, EOF, EOI OR
                                       ERROR #
          BEGIN
          TEST DUMMY;                # SKIP, NO RECORD READ #
          END
 
 
#
*     SKIP THIS RECORD IF THE *SM* IN THE *PFC* IS NOT THE ONE BEING
*     PROCESSED.
#
 
        IF EXTR$SM[0] NQ SMINDX
        THEN
          BEGIN
          TEST DUMMY;
          END
#
*     SKIP THIS RECORD IF THE GROUP IN THE *PFC* IS NOT THE ONE
*     BEING PROCESSED.
#
 
      IF EXTR$GP[0] NQ GROUP
      THEN
        BEGIN
        TEST DUMMY;
        END
 
 
#
*     CHECK FOR VALID *ASA* IN THE *PFC*.
#
 
        IF EXTR$GP[0] GR MAXGP
          OR EXTR$GPT[0] GR MAXGRT
          OR EXTR$AU[0] GR INAVOT
        THEN                         # *ASA* OUT OF RANGE #
          BEGIN
          VLWPROB(REC"ASA");         # BUILD PROBLEM ENTRY #
          TEST DUMMY;
          END
 
#
*     DO NOT CHECK THE PFC AGAINST THE SFM CATALOG
*     IF THE CATALOG IS EMPTY.
#
 
      IF VTLAST LS VTFIRST
      THEN
        BEGIN
        TEST DUMMY;
        END
 
#
*     USING THE *ASA*, LOCATE AND EDIT THE *VT* ENTRY FOR THIS RECORD.
#
 
        P<VTLINK> = LOC(VTPTR);      # BUILD LINK TO *VT* ENTRY #
        VTL$GRT[0] = EXTR$GPT[0];
        VTL$AU[0] = EXTR$AU[0];
        IF (VTL$WORD[0] LS VTFIRST) OR (VTL$WORD[0] GR VTLAST)
        THEN                         # INVALID LINK #
          BEGIN
          LINK$NO = XCOD(EXTR$UI[0]);
          MESSAGE(LINK,SYSUDF1);
          MP$WD[1] = " VLAPFC INVALID LINK ";
          VLERROR(VE"SYSERR",ABRT);  # ABORT WITH MESSAGE #
          END
 
        VTEN$WORD[0] = VT$ITEM[VTPTR];  # GET ENTRY #
 
#
*     IF *VT* ENTRY IS ALREADY OWNED AND THE MULTIPLE OWNER FLAG
*     IS NOT SET, 1) SET IT, 2) UPDATE THE PROBLEM TYPE FIELD,
*     AND 3) INCREMENT THE MULTIPLE OWNERS COUNTER.  THIS COUNTER
*     WILL BE USED IN VLAPFC2 TO LOCATE THE FIRST OWNER(S).
#
 
        IF VTEN$OWN AND NOT VTEN$MULT
        THEN                         # MULTIPLE OWNER DETECTED #
          BEGIN
          VTEN$MULT = TRUE;          # SET MULTIPLE OWNER FLAG #
          VTEN$PROB = VTEN$PROB LOR VTP$TYP[BMUL];  # SET PROBLEM
                                                      TYPE #
          GMO = GMO + 1;             # INCREMENT OWNERS #
          END
 
        VTEN$OWN = TRUE;             # SET OWNER FLAG #
 
#
*     IF THE DATA ERROR FLAG IS SET IN THE *PFC*, SET THE ERROR FLAG
*     IN THE *VT* AND UPDATE THE PROBLEM FIELD.
#
 
        IF EXTR$DERR[0]
        THEN
          BEGIN
          VTEN$RERR[0] = TRUE;
          VTEN$PROB[0] = VTEN$PROB[0] LOR VTP$TYP[BRER];
          TPFCERRS = TPFCERRS + 1;
          END
 
#
*     IF THE SYSTEM ERROR FLAG IS SET IN THE *PFC*, SET THE ERROR FLAG
*     IN THE *VT* AND UPDATE THE PROBLEM FIELD.
#
 
        IF EXTR$SYS[0]
        THEN
          BEGIN
          VTEN$SYS[0] = TRUE;
          VTEN$PROB[0] = VTEN$PROB[0] LOR VTP$TYP[BSYS];
          TPFCERRS = TPFCERRS + 1;
          END
 
#
*     IF THE *PFC* DOES NOT POINT TO THE HEAD OF CHAIN, SET THE ERROR
*     FLAG AND UPDATE THE PROBLEM TYPE FIELD.
#
 
        IF NOT VTEN$HOC[0]
        THEN
          BEGIN
          VTEN$MSH[0] = TRUE;
          VTEN$PROB[0] = VTEN$PROB[0] LOR VTP$TYP[BMSH];
          END
 
#
*     IF THE FREE CARTRIDGE FLAG IS SET ON CARTRIDE THEN ADD
*     A RECORD TO THE FIXIT FILE.
#
 
        IF VTEN$FCF[0] AND NOT EXTR$FF[0]
        THEN                        # BUILD FICIT FILE ENTRY #
          BEGIN
          VLWFIX(REC"FCF");
          END
 
#
*     IF THE *PFC* POINTS TO A CHAIN WITH PROBLEMS, ADD THIS
*     ENTRY TO THE PROBLEM FILE.
#
 
        IF VTEN$PROB[0] NQ 0
        THEN
          BEGIN
          VLWPROB(REC"OTHR");        # BUILD PROBLEM ENTRY #
          END
 
        VT$ITEM[VTPTR] = VTEN$WORD[0];  # STORE THE *VT* ENTRY #
 
#
*     IF THE *VT* ENTRY WAS NOT THE HEAD OF CHAIN, UPDATE THE *HOC*.
#
 
        IF VTEN$POINT[0] NQ VTPTR
        THEN
          BEGIN  # UPDATE *HOC* ENTRY #
          I = VTEN$PROB[0];          # SAVE PROBLEM OF MEMBER #
          VTEN$WORD[0] = VT$ITEM[VTEN$POINT[0]];  # GET *HOC* ENTRY #
          IF VTEN$OWN[0]
          THEN
            BEGIN
            VTEN$MULT[0] = TRUE;
            VTEN$PROB[0] = VTEN$PROB[0] LOR VTP$TYP[BMUL];
            GMO = GMO + 1;
            END
 
          VTEN$OWN[0] = TRUE;
          VTEN$PROB[0] = VTEN$PROB[0] LOR I;  # PROBLEM OF MEMBER #
          VT$ITEM[VTEN$POINT[0]] = VTEN$WORD[0];
          END  # UPDATE *HOC* ENTRY #
 
        END  # SCAN SUBFAMILY *PFC* ENTRIES #
 
#
*     IF AN UNEXPECTED *CIO* ERROR OCCURRED, ABORT.
#
 
      IF STAT EQ CIOERR
      THEN
        BEGIN
        MP$WD[1] = "VLAPFC";         # NAME FOR MESSAGE #
        VLERROR(VE"SYSERR",ABRT);    # ABORT WITH MESSAGE #
        END
 
#
*     IF THERE ARE GLOBAL MULTIPLE OWNERS, PERFORM VLAPFC2 TO FIND
*     THE FIRST OWNER OF THE FILE.
#
 
      IF GMO GR 0
      THEN
        BEGIN
        VLAPFC2(GMO,GROUP);
        END
 
      END  # VLAPFC #
 
    TERM
PROC VLAPFC2(CNT,GROUP);
# TITLE VLAPFC2 - ANALYZE *PFC* PASS 2.                               #
 
 
      BEGIN  # VLAPFC2 #
 
#
**    VLAPFC2 - ANALYZE THE *PFC* PASS 2.
*
*     *VLAPFC2* READS THE *PFC* EXTRACT FILE TO FIND THE FIRST OWNER
*     SINCE MULTIPLE OWNERS WERE FOUND IN *VLAPFC*.  ALL OTHER
*     INTERSECTIONS WITH THIS PARTICULAR CHAIN ARE MARKED IN *VLAPFC*.
*
*     PROC VLAPFC2(CNT)
*
*     ENTRY     (CNT)            - COUNT OF MULTIPLE OWNERS.
*               (SMINDX)        - *SM* NUMBER BEING PROCESSED.
*               ARRAY VTTABLE    - VALIDATION TABLE ENTRIES.
*               ARRAY EXTRACTFIL - *PFC* EXTRACT FILE *FET*.
*
*     EXIT      FOR THE *PFC* ENTRY THAT IS THE "FIRST" OWNER -
*               . *VT* ENTRY *VTEN$1ST* FLAG IS SET.
*               . A PROBLEM FILE RECORD IS WRITTEN AS "OTHR" RECORD
*                 TYPE.
#
 
      ITEM GROUP      I;             # GROUP BEING PROCESSED #
      ITEM CNT        I;             # COUNT OF MULTIPLE *PFC* OWNERS #
 
#
****  PROC VLAPFC2 - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC READ;                   # INTERFACE TO *READ* MACRO #
        PROC READW;                  # INTERFACE TO *READW* MACRO #
        PROC REWIND;                 # INTERFACE TO *REWIND* MACRO #
        PROC VLWPROB;                # WRITE PROBLEM FILE RECORD #
        END
 
#
****  PROC VLAPFC2 - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF LISTING #
 
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLV
 
                                               CONTROL EJECT;
 
#
*     READ THE *PFC* EXTRACT FILE.
#
 
      REWIND(EXTRACTFIL,RCL);
      READ(EXTRACTFIL,NRCL);
 
#
*     READ THE EXTRACT FILE UNTIL, 1) THE FILE STATUS IS NOT OK,
*     OR 2) THERE ARE NO MORE MULTIPLE OWNERS.
#
 
      STAT = 0;
      REPEAT WHILE STAT EQ OK AND (CNT GR 0)
      DO                             # PROCESS THE EXTRACT RECORD #
        BEGIN  # READING EXTRACT FILE #
        READW(EXTRACTFIL,EXTRECORD,RLEXTR,STAT);  # GET THE EXTRACT
                                                    RECORD #
        IF STAT NQ OK
        THEN
          BEGIN
          TEST DUMMY;                # DETECTED EOR, EOF, EOI OR ERROR
                                     #
          END
 
 
#
*     PROCESS ONLY THE RECORDS FOR THE GIVEN SM.
#
 
        IF EXTR$SM[0] NQ SMINDX
        THEN                         # NOT SELECTED #
          BEGIN
          TEST DUMMY;
          END
 
        IF EXTR$GP[0] NQ GROUP
        THEN
          BEGIN
          TEST DUMMY;
          END
 
#
*     USING THE *ASA* IN THE EXTRACT RECORD, DEVELOP THE INDEX TO
*     THE *VT* ARRAY FOR THIS RECORD.
#
 
        P<VTLINK> = LOC(VTPTR);      # BUILD LINK TO *VT* ENTRY #
        VTL$GRT[0] = EXTR$GPT[0];
        VTL$AU[0] = EXTR$AU[0];
 
        IF (VTL$WORD[0] LS VTFIRST) OR (VTL$WORD[0] GR VTLAST)
        THEN
          BEGIN
          TEST DUMMY;                # SKIP IF THE INDEX IS BAD #
          END
 
#
*     GET THE *VT* ENTRY FOR THIS *PFC* EXTRACT RECORD.
#
 
        VTEN$WORD[0] = VT$ITEM[VTPTR];  # GET *VT* ENTRY #
 
#
*     DETERMINE IF THIS IS THE 1ST OWNER OF MULTIPLY-OWNED FILE.
#
 
        IF VTEN$MULT[0] AND (NOT VTEN$1ST[0])
        THEN
          BEGIN
          VTEN$1ST[0] = TRUE;
          VT$ITEM[VTPTR] = VTEN$WORD[0];  # UPDATE ENTRY #
          VLWPROB(REC"OTHR");        # BUILD PROBLEM ENTRY #
          CNT = CNT - 1;
          END
 
        END  # READING EXTRACT FILE #
 
      END  # VLAPFC2 #
 
    TERM
PROC VLBFILL(FLD,NWDS);
# TITLE VLBFILL - BLANK FILL.                                         #
 
      BEGIN  # VLBFILL #
 
#
**    VLBFILL - BLANK FILL.
*
*     *VLBFILL* CHANGES ALL BINARY ZERO CHARACTERS STARTING IN *FLD*
*     TO DISPLAY CODE BLANKS FOR A LENGTH OF *NWDS*.
*
*     PROC VLBFILL
*
*     ENTRY     (FLD) - THE FIELD TO SCAN.
*               (WDS) - NUMBER OF WORDS TO SCAN.
*
*     EXIT      (FLD) - CONTAINS THE BLANK FILLED FIELD.
#
 
      ITEM FLD        I;             # FIELD TO SCAN #
      ITEM NWDS       I;             # NUMBER OF WORDS TO SCAN #
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
 
      ITEM CHARINDX   I;             # INDEX FOR CHARACTERS SCANNED #
      ITEM NCHAR      I;             # NUMBER OF CHARACTERS TO SCAN #
 
      BASED
      ARRAY SCAN [0:0] S(200);       # TO SCAN FIELD #
      ITEM SCAN$WD    C(00,00,200);
 
                                               CONTROL EJECT;
 
#
*     LOOK FOR A BINARY ZERO CHARACTER IN THE SPECIFIED FIELD AND
*     CHANGE IT TO A BLANK.
#
 
 
      P<SCAN> = LOC(FLD);
 
      NCHAR = NWDS * 10;             # NUMBER OF CHARACTERS TO SCAN #
      SLOWFOR CHARINDX = 0 STEP 1 UNTIL NCHAR - 1
      DO
        BEGIN  # CHARINDX #
        IF C<CHARINDX,1>SCAN$WD[0] EQ 00
        THEN                         # FOUND A BINARY ZERO #
          BEGIN
          C<CHARINDX,1>SCAN$WD[0] = " ";  # REPLACE WITH A BLANK #
          END
 
        END  # CHARINDX #
 
      END  # VLBFILL #
 
    TERM
PROC VLBICT(E1,E2);
# TITLE VLBICT - INTERSECTING CHAIN REPORT.                           #
 
#
***
#
 
      BEGIN  # VLBICT #
 
#
**    VLBICT - INTERSECTING CHAIN REPORT.
*
*     *VLBICT* ISSUES THE INTERSECTING CHAIN DETAIL LINE TO THE
*     REPORT FILE AND ALSO ISSUES THE SUBCATALOG HEADING LINE
*     WHEN CALLED THE FIRST TIME FOR THE SUBCATALOG.
*
*     PROC VLBICT(E1,E2)
*
*     ENTRY     (E1)      - *VT* ENTRY INDEX (*FCT* ORDINAL, AU)
*                           FOR ENTRY 1.
*               (E2)      - *VT* ENTRY INDEX (*FCT* ORDINAL, AU)
*                           FOR ENTRY 2.
*               (RPTFADR) - ADDRESS OF THE REPORT FILE *FET*.
*               (SCDTLH)  - SUBCATALOG DETAIL HEADING FLAG.
*
*     EXIT      INTERSECTING CHAIN DETAIL LINE WRITTEN TO THE REPORT
*               FILE.
*               (SCRPTED) - SUBCATALOG REPORTED FLAG.
*               (SCDTLH)  - SUBCATALOG DETAIL HEADING FLAG.
*
*     NOTES     TO FORCE LEADING ZEROS ON THE *FCT* NUMBER AND
*               THE AU NUMBER THE *ZFD* VALUE IS ADDED BEFORE
*               CONVERSION.
*
#
 
      ITEM E1         I;             # CHAIN ENTRY 1 #
      ITEM E2         I;             # CHAIN ENTRY 2 #
 
#
****  PROC VLBICT - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        FUNC VLNTC C(10);            # NUMERIC TO CHARACTER
                                       CONVERSION #
        PROC VLSUBHD;                # ISSUE REPORT SUBHEADING #
        END
 
#
****  PROC VLBICT - XREF LIST END.
#
 
 
 
      DEF LISTCON #0#;               # TURN OFF LISTING #
 
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLV
 
#
*     INTERSECTING CHAIN DETAIL LINE FOR THE REPORT FILE.
#
 
      ARRAY ICLINE [0:0] S(3);       # INTERSECTING CHAIN REPORT LINE
                                     #
        BEGIN
        ITEM ICL$DEF    C(00,00,30) = ["000-0000       000-0000"];
        ITEM ICL$FCT1   C(00,00,03);  # *FCT* OF ENTRY ONE #
        ITEM ICL$AU1    C(00,24,04);  # *AU* OF ENTRY ONE #
        ITEM ICL$FCT2   C(01,30,03);  # *FCT* OF ENTRY TWO #
        ITEM ICL$AU2    C(01,54,04);  # *AU* OF ENTRY TWO #
        END
 
                                               CONTROL EJECT;
 
#
*     IF THE DETAIL HEADING HAS NOT BEEN PRINTED, PRINT IT.
#
 
 
      IF NOT SCDTLH
      THEN
        BEGIN
        VLSUBHD(SHTYP"ICT");         # PRINT DETAIL HEADING #
        SCRPTED = TRUE;              # SUBCATALOG REPORTED FLAG #
        SCDTLH = TRUE;               # SET SUBCATALOG DETAIL HEADING
                                       FLAG #
        END
 
#
*     FORMAT AND PRINT THE INTERSECTING REPORT LINE.
#
 
      P<VTLINK> = LOC(E1);             # *VT* LINK FOR ENTRY 1 #
      ICL$FCT1[0] = VLNTC(GROUPX*16+VTL$GRT[0]
        +ZFD,"XCDD",3);
      ICL$AU1[0] = VLNTC(VTL$AU[0]    # GET AU #
                    +ZFD,"XCDD",4);
      P<VTLINK> = LOC(E2);             # *VT* LINK FOR ENTRY 2 #
      ICL$FCT2[0] = VLNTC(GROUPX*16+VTL$GRT[0]
                    +ZFD,"XCDD",3);
      ICL$AU2[0] = VLNTC(VTL$AU[0]    # GET AU #
                    +ZFD,"XCDD",4);
 
      RPLINE(RPTFADR,ICLINE,24,30,EOPL);  # ISSUE LINE TO REPORT #
 
 
      RETURN;
      END  # VLBICT #
 
    TERM
PROC VLBLDVT(GROUP);
 
# TITLE VLBLDVT - BUILD VALIDATION TABLE.                             #
 
      BEGIN  # VLBLDVT #
 
#
**    VLBLDVT - BUILD THE VALIDATION TABLE.
*
*     *VLBLDVT* READS THE *FCT* IN THE SELECTED SUBCATALOG (SM)
*     OF THE SFM CATALOG BEING PROCESSED AND BUILDS A *VT*
*     TABLE ENTRY FOR EACH AU OF EACH *FCT* ENTRY.
*
*     PROC VLBLDVT
*
*     ENTRY     (SMINDX)  - *SM* INDEX CURRENTLY PROCESSING.
*               (PAR$AM)   - AM PARAMETER FROM CONTROL CARD.
*               (PAR$FM)   - FM PARAMETER FROM CONTROL CARD.
*               (SBINDX)   - SUBFAMILY CURRENTLY PROCESSING.
*               P<VTTABLE> - START OF *VT* TABLE IN MEMORY.
*               (GROUP) - GROUP THAT WILL BE PROCESSED.
*
*     EXIT      (VTFIRST)       - INDEX OF FIRST ENTRY IN THE TABLE.
*               (VTLAST)        - INDEX OF LAST ENTRY IN THE TABLE.
*               (ARRAY VTTABLE) - CONTAINS ENTRIES FOR EACH AU IN
*                                 THE SUBCATALOG.
*
*     MESSAGES  *SFM CATALOG READ ERROR.*
*
*     NOTES     IF THE AM PARAMETER WAS SELECTED, THE *VLCMAP*
*               ROUTINE IS CALLED TO CHECK THE SMMAP ENTRY FOR EACH
*               *FCT* READ.
*
*               THESE *VT* ENTRY FIELDS ARE SET DEPENDING ON THE
*               *FCT* ENTRY -
*               . VTEN$NONE - NO CARTRIDGE ( *VSN* = BLANKS ).
*               . VTEN$SM  - SMMAP ENTRY ERROR.
*               . VTEN$INHB - INHIBIT FLAG SET.
*               . VTEN$LOST - LOST CARTRIDGE FLAG SET.
*               . VTEN$EWPE - EXCESSIVE WRITE PARITY ERRORS.
*               . VTEN$CONF - AU CONFLICT FLAG SET.
*               . VTEN$FROZ - FROZEN FLAG SET.
*               . VTEN$SOF  - START OF FRAGMENT SET.
*               . VTEN$ALOC - AU ALLOCATED.
*               . VTEN$HOC  - AU IS HEAD OF CHAIN.
*               . VTEN$EOC  - AU IS END OF CHAIN.
*               . VTEN$LINK - INDEX TO NEXT AU IN CHAIN.
*
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTINGS #
 
#
****  PROC VLBLDVT - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CGETFCT;                # GET AN *FCT* ENTRY #
        PROC VLCMAP;                 # *SM* MAP LOOKUP #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        END
 
#
****  PROC VLBLDVT - XREF LIST END.
#
 
 
 
 
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBCMS
*CALL COMBMAP
*CALL COMBMCT
*CALL COMTVLD
*CALL COMTVLM
*CALL COMTVLV
 
      ITEM EOCS     B;               # SAVE END OF CHAIN BIT #
      ITEM GROUP    U;               # GROUP TO BE PROCESSED #
      ITEM LINKHS   I;               # SAVE LINK POINTER HEADER #
      ITEM NEXT     I;               # INDEX TO *FCT* ORD TABLE #
      ITEM SMERR    B;               # FLAG RESULTS OF VLCMAP PROCESS #
      ITEM SW       U;               # AU WORD OFFSET #
      ITEM SP       U;               # AU POSITION IN WORD #
      ITEM START    I;               # START OF PROCESSING #
      ITEM TERMX    I;               # TERMINATION ORDINAL #
      ITEM ITEMP    I;               # TEMPORARY #
      ITEM I        I;               # INDUCTION VARIABLE #
      ITEM VPOINT   U;               # VOLUME HEAD POINTER #
 
                                               CONTROL EJECT;
 
#
*     INITIALIZE *VT* POINTERS.
#
 
      P<VTLINK> = LOC(VTFIRST);      # BUILD STARTING LINK ADDRESS #
      VTL$GRT[0] = 0;
      VTL$AU[0] = 1;
      VTPTR = VTL$WORD[0] - 1;       # INITIALIZE ENTRY POINTER #
      GRTX = -1;
      EOCS = FALSE;
 
#
*     PROCESS FOR EACH *FCT* RECORD.
#
 
      START = GROUP * 16;
      TERMX = START + 15;
      SLOWFOR FCTORD = START STEP 1
        WHILE FCTORD LQ TERMX
        AND FCTORD LQ (PRM$ENTRC[SMINDX] + 15)
      DO
        BEGIN  # *FCT* PROCESSING #
        GRTX = GRTX + 1;
 
#
*     READ THE *FCT* RECORD.
#
 
      STAT = 0;
      FB$CWRD[0] = 0;
        CGETFCT(PAR$FM,SBINDX,SMINDX,FCTORD,LOC(VLFCTAREA),0,STAT);
        IF STAT NQ CMASTAT"NOERR"
        THEN
          BEGIN
          VLERROR(VE"CATR",ABRT);    # ABORT WITH MESSAGE #
          END
 
        P<FCT> = LOC(VLFCTAREA);
        SMERR = FALSE;              # INITIALIZE TO NO *SM* ERROR #
 
#
*     IF THE *AM* OPTION WAS SELECTED, PERFORM A SMMAP CHECK.
#
 
        IF PAR$AM NQ 0
        THEN
          BEGIN
          VLCMAP(SMERR);
          END
 
#
*     PROCESS FOR EACH AU OF THE *FCT* RECORD.
#
 
        SLOWFOR AUINDX = 1 STEP 1 UNTIL INAVOT
        DO
          BEGIN  # AU PROCESSING #
 
#
*     CALCULATE AU WORD AND OFFSET INTO *FCT* AREA.
#
 
          SW = FCT$WD(AUINDX);
          SP = FCT$WP(AUINDX);
 
          IF FCT$CAUF(SW,SP) EQ 0
          THEN                  # SAVE POINTER AT VOLUME START #
            BEGIN
            VPOINT = FCT$LINK(SW,SP);
            END
 
#
*     BUILD *VT* ENTRY FOR THE AU.
#
 
          VTEN$WORD[0] = 0;
          IF FCT$CSND[0] EQ "        "
            OR FCT$1ST[0] EQ 0
          THEN
 
#
*     BUILD *VT* ENTRY WHEN NO CARTRIDGE.
#
 
            BEGIN
            VTEN$NONE[0] = TRUE;
            EOCS = FALSE;
            VPOINT = 0;
            END
 
          ELSE
 
#
*     BUILD *VT* ENTRY WHEN CARTRIDGE EXISTS.
#
 
            BEGIN  # CARTRIDGE EXISTS #
            VTEN$SME[0] = SMERR;
            VTEN$INHB[0] = FCT$IAF[0];
            VTEN$LOST[0] = FCT$LCF[0];
            VTEN$EWPE[0] = FCT$EEF[0];
            VTEN$CONR[0] = FCT$AUCF(SW,SP);
            VTEN$FROZR[0] = FCT$FRCF(SW,SP);
            VTEN$SOFR[0] = FCT$SFF(SW,SP);
            VTEN$ALOCR[0] = FCT$FBF(SW,SP);
            VTEN$FCF[0] = FCT$FCF[0];
 
#
*     PROCESS AN ALLOCATED HEAD OF VOLUME *AU*.
#
 
            IF VTEN$ALOC[0] AND FCT$CAUF(SW,SP) EQ 0
            THEN
              BEGIN  # AU ALLOCATED #
              ITEMP = FCT$CC(SW,SP);
              IF ITEMP EQ CHAINCON"FIRST"
              THEN
                BEGIN
                VTEN$HOC[0] = TRUE;  # HEAD OF CHAIN #
                END
 
              IF ITEMP EQ CHAINCON"LAST"
              THEN
                BEGIN
                EOCS = TRUE;
                END
 
              IF ITEMP EQ CHAINCON"ONLY"
              THEN
                BEGIN
                VTEN$HOC[0] = TRUE;  # SET BOTH HEAD AND #
                EOCS = TRUE;
                END
 
#
*     IF NOT THE END OF THE CHAIN, SET LINK TO NEXT IN CHAIN.
#
 
              IF NOT EOCS
              THEN
                BEGIN  # LINK TO THE NEXT AU #
                ITEMP = FCT$CLKOCL(SW,SP);
                LINKHS = GRTX;
                IF ITEMP NQ 0
                THEN
                  BEGIN
                  VTEN$OCL[0] = ITEMP;
                  LINKHS = FCT$OCL[0];
                  IF ITEMP EQ 2
                  THEN
                    BEGIN
                    LINKHS = FCT$OCL1[0];
                    END
 
                  ELSE
                    BEGIN
                    IF ITEMP EQ 3
                    THEN
                      BEGIN
                      LINKHS = FCT$OCL2[0];
                      END
 
                    END
 
                  END
 
                END  # LINK TO THE NEXT AU #
 
              END  # AU ALLOCATED #
 
            IF VTEN$ALOC[0] AND FCT$LEN(SW,SP) NQ 0
            THEN            # *AU*-S REMAIN IN VOLUME #
              BEGIN
              VTEN$LINKL[0] = AUINDX + 1;
              VTEN$LINKH[0] = GRTX;
              END
 
            IF VTEN$ALOC[0] AND FCT$LEN(SW,SP) EQ 0
            THEN
              BEGIN
              VTEN$LINKL[0] = VPOINT;
              VTEN$LINKH[0] = GRTX;
              VTEN$EOC[0] = EOCS;
              IF EOCS
              THEN
                BEGIN
                VTEN$LINKH[0] = 0;
                END
 
              IF NOT EOCS
              THEN
                BEGIN
                VTEN$LINKH[0] = LINKHS;
                END
 
              EOCS = FALSE;
              END
 
            END  # CARTRIDGE EXISTS #
 
#
*     PUT *VT* ENTRY INTO TABLE IN MEMORY.
#
 
          VTPTR = VTPTR + 1;         # ADDRESS FOR NEXT ENTRY #
 
          VT$ITEM[VTPTR] = VTEN$WORD[0];  # PUT ENTRY IN TABLE #
 
          END  # AU PROCESSING #
 
        VTPTR = VTPTR + 2048 - INAVOT;
        END  # *FCT* PROCESSING #
 
#
*     MARK END OF ENTRIES IN *VT* TABLE.
#
 
      VTLAST = VTPTR;                # SAVE END OF *VT* TABLE #
 
      RETURN;
 
      END  # VLBLDVT #
 
    TERM
PROC VLCFS;
# TITLE VLCFS - CHAIN FRAGMENT SCAN.                                  #
 
 
      BEGIN  # VLCFS #
 
#
**    VLCFS - CHAIN FRAGMENT SCAN.
*
*     *VLCFS* SCANS ALL ENTRIES IN THE *VT* TABLE TO DETECT CHAIN
*     FRAGMENTS.  CHAIN FRAGMENTS ARE *VT* ENTRIES THAT ARE ALLOCATED
*     BUT ARE NOT MARKED AS MEMBERS OF NORMAL CHAINS (SEE *VLNCS*).
*
*     PROC VLCFS
*
*     ENTRY     (VTFIRST)     - INDEX TO FIRST ENTRY IN *VT*.
*               (VTLAST)      - INDEX TO LAST ENTRY IN *VT*.
*               ARRAY VTTABLE - VALIDATION TABLE ENTRIES.
*
*     EXIT      THE FOLLOWING FIELDS IN THE *VT* ENTRIES MAY BE
*               UPDATED IF FRAGMENTS ARE DETECTED.
*               . VTEN$POINT - INDEX TO HEAD OF CHAIN.
*               . VTEN$SOF   - START OF FRAGMENT FLAG SET.
*               . VTEN$ILL   - SET IF CHAIN IS ILL-FORMED.
*               . VTEN$INTC  - SET IF CHAIN IS INTERSECTING.
*
*               THE INTERSECTING CHAIN DETAIL LINES ARE ISSUED
*               TO THE REPORT FILE IF INTERSECTIONS ARE DETECTED.
*
*     NOTES     AN ENTRY IS MARKED AS BEING ON A CHAIN BY
*               SETTING THE VTEN$POINT FIELD EQUAL TO *HOC* INDEX.
*
*               THE CHAIN IS FOLLOWED UNTIL -
*                . AN END-OF-CHAIN ENTRY IS DETECTED.
*                . AN ILL-FORMED CHAIN IS DETECTED.
*                . AN INTERSECTING CHAIN IS DETECTED.
*
*               AN ILL-FORMED CHAIN HAS AN ENTRY THAT LINKS TO ANOTHER
*               ENTRY ALREADY ON THE CHAIN OR LINKS TO AN ENTRY
*               THAT IS NOT ALLOCATED OR HAS A LINK THAT IS NOT ZERO
*               WHEN THE *EOC* IS SET.
*
*               AN INTERSECTING CHAIN IS ONE WHOSE ENTRY LINKS TO AN
*               ENTRY ALREADY ON A DIFFERENT CHAIN.
*
*               IF A FRAGMENT CHAIN RUNS INTO ANOTHER FRAGMENT CHAIN,
*               THE SECOND FRAGMENT IS CONSIDERED A TAIL OF THE
*               FIRST.  IT IS FOLLOWED AND RE-MARKED SO THAT ITS
*               POINTER FIELD *VTEN$POINT* CONTAINS THE INDEX OF THE
*               FIRST START OF FRAGMENT ENTRY.
*
#
 
#
****  PROC VLCFS - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC VLBICT;                 # INTERSECTING CHAIN REPORT #
        END
 
#
****  PROC VLCFS - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLV
 
 
      STATUS CHAIN                   # CHAIN STATUS #
        OK,                          # GOOD CHAIN #
        ILL,                         # ILL-FORMED CHAIN #
        INTC;                        # INTERSECTING CHAIN #
 
      ITEM ENDCHAIN   B;             # END OF CHAIN FLAG #
      ITEM HOCSTAT    S : CHAIN;     # CHAIN STATUS #
      ITEM I          I;             # TEMPORARY VARIABLE #
      ITEM TAIL       B;             # TAIL FLAG #
      ITEM TAILPTR    I;             # *VT* INDEX OF A TAIL #
 
                                               CONTROL EJECT;
 
#
*     SCAN *VT* FOR ALLOCATED ENTRIES NOT ON CHAINS.  THIS VALIDATION
*     STEP IS TO IDENTIFY PROBLEMS WITH AU-S THAT ARE NOT ON VALID
*     CHAINS.
#
 
      SLOWFOR I = VTFIRST STEP 1 UNTIL VTLAST
      DO
        BEGIN  # *VT* ENTRY #
        VTEN$WORD[0] = VT$ITEM[I];   # GET *VT* ENTRY #
 
#
*     FIND AN ALLOCATED AU THAT IS NOT ON A CHAIN.
*     IT IS DEFINED AS A FRAGMENT CHAIN.  IF THE ENTRY IS ALREADY
*     ASSIGNED TO A CHAIN, THE VTEN$POINT IS SET.
#
 
        IF NOT VTEN$ALOC[0] OR VTEN$POINT[0] NQ 0
        THEN
          BEGIN
          TEST I;                    # SKIP, NOT A FRAGMENT #
          END
 
 
        VTEN$SOF[0] = TRUE;          # SET START OF FRAGMENT FLAG #
 
#
*     INITIALIZE FIELDS USED TO FOLLOW THE FRAGMENT CHAIN.
*     THE VARIABLE I = INDEX OF FRAGMENT *HOC*.
#
 
        VTPTR = I;                   # START AT THIS *HOC* #
        ENDCHAIN = FALSE;
        HOCSTAT = S"OK";
        TAIL = FALSE;
        TAILPTR = 0;
 
#
*     PROCESS EACH ENTRY IN FRAGMENT STARTING WITH *HOC* ENTRY.
#
 
        REPEAT WHILE NOT ENDCHAIN
        DO                           # SCAN FRAGMENT CHAIN #
          BEGIN  # FRAGMENT PROCESSING #
 
          IF (VTEN$POINT[0] EQ 0) OR (VTEN$POINT[0] EQ TAILPTR)
          THEN
 
#
*     ENTRY BELONGS TO THIS CHAIN (EITHER A NEW ENTRY OR A TAIL ENTRY).
#
 
            BEGIN  # ADD ENTRY TO THE FRAGMENT CHAIN #
            VTEN$POINT[0] = I;
            IF NOT VTEN$ALOC[0]
            THEN
              BEGIN
              VTEN$SOF[0] = TRUE;
              END
 
            IF NOT VTEN$ALOC[0] OR VTEN$EOC[0] AND VTEN$LINK[0] NQ 0
              THEN
              BEGIN
              HOCSTAT = S"ILL";      # ILL-FORMED CHAIN #
              END
 
            END  # ADD ENTRY TO THE FRAGMENT CHAIN #
 
          ELSE
 
#
*     ENTRY ALREADY ON SOME OTHER CHAIN.
#
 
            BEGIN  # ENTRY ON A CHAIN #
            IF VTEN$SOF[0] AND (VTPTR NQ I)  # NOT LOOPING #
              AND VTEN$ALOC[0] AND VTPTR EQ VTEN$POINT[0]
            THEN
 
#
*     THE OTHER CHAIN IS A TAIL.  THE CHAIN BEING FOLLOWED POINTS TO
*     THE BEGINNING OF A FRAGMENT CHAIN.  MAKE THE TWO CHAINS INTO ONE
*     FRAGMENT CHAIN BY FOLLOWING THIS TAIL AND UPDATING THE
*     VTEN$POINT.
#
 
              BEGIN  # START TAIL #
              TAIL = TRUE;
              VTEN$SOF[0] = FALSE;
              VTEN$INTC[0] = FALSE;
              VTEN$ILL[0] = FALSE;
              TAILPTR = VTEN$POINT[0];  # MARK THIS ONE, MARK REST IN
                                          MAIN LOOP #
              VTEN$POINT[0] = I;
              END  # START TAIL #
 
            ELSE
 
#
*     CHAIN INTERSECTS OR IS ILL-FORMED.
#
 
              BEGIN  # PROBLEM CHAIN #
              VTEN$INTS[0] = TRUE;
              IF VTEN$POINT[0] EQ I
              THEN                   # THE CHAIN IS ILL-FORMED #
                BEGIN
                HOCSTAT = S"ILL";
                VTEN$LOOP[0] = TRUE;
                END
 
              ELSE                   # THE CHAIN INTERSECTS #
                BEGIN
                HOCSTAT = S"INTC";
                VLBICT(I,VTEN$POINT[0]);  # REPORT CHAINS #
                END
 
              END  # PROBLEM CHAIN #
 
            END  # ENTRY ON A CHAIN #
 
 
 
#
*     UPDATE THE AU ENTRY.
#
 
          VT$ITEM[VTPTR] = VTEN$WORD[0];  # UPDATE ENTRY #
 
#
*     AN END OF CHAIN CONDITION IS SET HERE IF:
*       1) *EOC* FLAG IS SET, OR
*       2) A LINKAGE PROBLEM HAS BEEN DETECTED.
#
 
          ENDCHAIN = VTEN$EOC[0] OR HOCSTAT NQ S"OK";  # BAD CHAIN #
 
#
*     GET LINK TO NEXT AU IF NOT AT END OF CHAIN.
#
 
          IF NOT ENDCHAIN
          THEN
            BEGIN  # GET NEXT LINK #
            VTPTR = VTEN$LINK[0];
 
            IF VTPTR LS VTFIRST OR VTPTR GR VTLAST
            THEN                     # LINK IS BAD #
              BEGIN
              HOCSTAT = S"ILL";      # ILL-FORMED CHAIN #
              ENDCHAIN = TRUE;
              END
 
            END  # GET NEXT LINK #
 
#
*     GET NEXT AU IN CHAIN.
#
 
          IF NOT ENDCHAIN
          THEN
            BEGIN
            VTEN$WORD[0] = VT$ITEM[VTPTR];  # NEXT IN CHAIN #
            END
 
          END  # FRAGMENT PROCESSING #
 
#
*     UPDATE OTHER HEAD OF CHAIN IF INTERSECTING.
#
 
        IF HOCSTAT EQ S"INTC"
        THEN
          BEGIN
          VTEN$WORD[0] = VT$ITEM[VTEN$POINT[0]];  # GET *HOC* ENTRY #
          VTEN$INTC[0] = TRUE;       # SET INTERSECTING FLAG #
          VT$ITEM[VTEN$POINT[0]] = VTEN$WORD[0];  # STORE *HOC* ENTRY #
          END
 
#
*     UPDATE HEAD OF CHAIN ENTRY.
#
 
        VTEN$WORD[0] = VT$ITEM[I];   # GET *HOC* ENTRY #
        IF HOCSTAT EQ S"ILL"
        THEN
          BEGIN
          VTEN$ILL[0] = TRUE;        # SET ILL-FORMED FLAG #
          END
 
        IF HOCSTAT EQ S"INTC"
        THEN
          BEGIN
          VTEN$INTC[0] = TRUE;       # SET INTERSECTING FLAG #
          END
 
        VT$ITEM[I] = VTEN$WORD[0];   # STORE *HOC* ENTRY #
 
        END  # *VT* ENTRY #
 
      END  # VLCFS #
 
    TERM
PROC VLCMAP(CMERR);
# TITLE VLCMAP - *SM* MAP LOOKUP.                                    #
 
 
      BEGIN  # VLCMAP #
 
#
**    VLCMAP - SMMAP LOOKUP.
*
*     *VLCMAP* READS THE SMMAP ENTRY FOR THE GIVEN Y,Z COORDINATES
*     IN THE *FCT* RECORD AND VERIFIES THAT THE ENTRY IS VALID.
*
*     PROC VLCMAP(CMERR)
*
*     ENTRY     (SMINDX)         - *SM* INDEX.
*               (FCTORD)          - *FCT* ORDINAL.
*               (PAR$FM)          - FAMILY.
*               (SBINDX)          - SUBFAMILY INDEX.
*               (ARRAY VLFCTAREA) - CONTAINS *FCT* RECORD.
*
*     EXIT      (CMERR)        = TRUE IF ERROR DETECTED.
*                              = FALSE IF NO ERROR.
*               (ARRAY VLCMAP) - BIT SET FOR GIVEN Y, Z IF THE
*                                SMMAP/FCT ENTRIES POINT TO EACH
*                                OTHER.
*
*               IF AN ERROR IS DETECTED, A PROBLEM FILE
*               RECORD (RT"FCT") IS WRITTEN.
*
*     MESSAGES  * SMMAP READ ERROR.*
*
*     NOTES     AN ERROR IN THE ENTRY IS DETECTED IF -
*               . IT IS NOT ASSIGNED TO THE SUBFAMILY.
*               . FAMILY IN ENTRY IS WRONG.
*               . SUBFAMILY IS WRONG.
*               . *FCT* ORDINAL IS WRONG.
*               . *CSN* IS WRONG.
*
#
 
      ITEM CMERR      B;             # INDICATES *SM* MAP ERROR #
 
#
****  PROC VLCMAP - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC MGETENT;                # RETURN THE MAP ENTRY TO THE
                                       CALLER #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC VLWPROB;                # WRITE PROBLEM FILE RECORD #
        PROC ZFILL;                  # ZERO FILLS A CHARACTER ITEM #
        END
 
#
****  PROC VLCMAP - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBCMS
*CALL COMBMAP
*CALL COMBMCT
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLM
 
 
      ITEM ORD        U;             # TO CALCULATE *SM* MAP ORDINAL #
 
                                               CONTROL EJECT;
 
 
      P<FCT> = LOC(VLFCTAREA);
 
#
*     SAVE Y AND Z COORDINATES.
#
 
      Y = FCT$Y[0];
      Z = FCT$Z[0];
 
      CMERR = FALSE;                 # ASSUME NO ERROR #
 
#
*     IF *FCT* DOES NOT POINT TO A SMMAP ENTRY, RETURN.
#
 
      IF Y EQ 0 AND Z EQ 0
      THEN
        BEGIN
        RETURN;
        END
 
      ZFILL(VLMAPAREA,MAPENTL);      # CLEAR MAP ENTRY AREA #
 
 
#
*     READ *SM* MAP ENTRY.
#
 
      ORD = MAXORD - Z - (Y * (MAX$Z+1));
      MGETENT(SMINDX,ORD,LOC(VLMAPAREA),STAT);  # GET *SM* ENTRY #
 
#
*     IF ERROR WHEN READING THE SMMAP, ISSUE MESSAGE AND ABORT.
#
 
      IF (STAT NQ CMASTAT"NOERR") AND (STAT NQ CMASTAT"ORDERR")
      THEN
        BEGIN
        VLERROR(VE"MAPR",ABRT);      # ABORT WITH MESSAGE #
        END
 
 
      P<SMUMAP> = LOC(VLMAPAREA);
#
*     IF MAP ENTRY IS FOR ANOTHER SUBFAMILY, RETURN.
#
 
      IF SBINDX NQ CM$SUB[0]
      THEN                             ##
        BEGIN
        RETURN;
        END
 
 
#
*     IF THE *FCT* POINTS TO AN INCORRECT SMMAP ENTRY, WRITE THE
*     ENTRY TO THE PROBLEM FILE.
#
 
      IF CM$CODE[0] NQ CUBSTAT"SUBFAM"  ##
        OR PAR$FM NQ CM$FMLYNM[0]    ##
        OR SBINDX NQ CM$SUB[0]       ##
        OR FCTORD NQ CM$FCTORD[0]    ##
        OR FCT$CSND[0] NQ CM$CSND[0]   # #
      THEN
        BEGIN
        CMERR = TRUE;
        CSN = FCT$CSND[0];
        VLWPROB(REC"FCT");           # WRITE PROBLEM ENTRY #
        END
 
#
*     IF *FCT* AND *SM* POINT TO EACH OTHER, SET THE BIT IN CMAP
*     ARRAY TO INDICATE THAT A *FCT* ENTRY EXISTS FOR THIS SMMAP
*     ENTRY.
#
 
      IF PAR$FM EQ CM$FMLYNM[0] AND SBINDX EQ CM$SUB[0]  ##
        AND FCTORD EQ CM$FCTORD[0]
      THEN
        BEGIN
        B<Y,1>VLCM$Z[Z] = 1;
        END
 
 
      END  # VLCMAP #
 
    TERM
PROC VLSMSC;
# TITLE VLSMSC - *SM* MAP SCAN.                                     #
 
 
      BEGIN  # VLSMSC #
 
#
**    VLSMSC - SMMAP SCAN.
*
*     *VLSMSC* READS THE SMMAP FILE TO FIND ALL ENTRIES ASSIGNED
*     TO THE SPECIFIED SUBFAMILY WHICH HAVE NO CORRESPONDING
*     *FCT* ENTRY (THE BIT IN THE *VLCMAP* ARRAY IS OFF).
*
*     PROC VLSMSC
*
*     ENTRY     (SMINDX)      - *SM* INDEX.
*               (PAR$FM)       - FAMILY.
*               (SBINDX)       - SUBFAMILY INDEX.
*               (ARRAY VLCMAP) - BIT MAP FOR SMMAP ENTRIES THAT
*                                HAVE VALID *FCT* ENTRIES.
*
*     EXIT      IF AN ERROR IS DETECTED, THEN A PROBLEM FILE
*               RECORD (RT"SM") IS WRITTEN.
*
*     MESSAGES  * SMMAP READ ERROR.*
#
 
#
****  PROC VLSMSC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC MGETENT;                # RETURN THE MAP ENTRY TO THE
                                       CALLER #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC VLWPROB;                # WRITE PROBLEM FILE RECORD #
        END
 
#
****  PROC VLSMSC - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBCMS
*CALL COMBMAP
*CALL COMBMCT
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLM
 
 
      ITEM ORD        I;             # ORDINAL #
 
                                               CONTROL EJECT;
 
#
*     READ THE ENTIRE SMMAP FILE.
#
 
      SLOWFOR Z = 0 STEP 1 UNTIL MAX$Z
      DO
        BEGIN  # Z COORDINATE SCAN #
        SLOWFOR Y = 0 STEP 1 UNTIL MAX$Y
        DO
          BEGIN  # Y COORDINATE SCAN #
          ORD = MAXORD - Z - (Y * (MAX$Z+1));
          MGETENT(SMINDX,ORD,LOC(VLMAPAREA),STAT);  # READ ENTRY #
          IF STAT NQ CMASTAT"NOERR"
          THEN
            BEGIN
            VLERROR(VE"MAPR",ABRT);  # ABORT WITH MESSAGE #
            END
 
          P<SMUMAP> = LOC(VLMAPAREA);
 
#
*     IF THE SMMAP ENTRY IS ASSIGNED TO THE SUBFAMILY BUT THERE
*     WAS NO CORRESPONDING *FCT* ENTRY, WRITE AN ENTRY TO THE PROBLEM
*     FILE.
#
 
          IF (CM$CODE[0] EQ CUBSTAT"SUBFAM")
            AND (CM$FMLYNM[0] EQ PAR$FM) AND (CM$SUB[0] EQ SBINDX)
              AND (B<Y,1>VLCM$Z[Z] EQ 0)
              AND CM$FCTORD[0] NQ 0
              AND CM$CSND[0] NQ " "
          THEN
            BEGIN
            CSN = CM$CSND[0];       # FIELDS FOR VLWPROB #
            FCTORD = CM$FCTORD[0];
            VLWPROB(REC"SM");       # WRITE PROBLEM FILE ENTRY #
            END
 
          END  # Y COORDINATE SCAN #
 
        END  # Z COORDINATE SCAN #
 
      END  # VLSMSC #
 
    TERM
PROC VLERROR((ERNUM),(ABTFLG));
# TITLE VLERROR - ISSUE ERROR MESSAGE.                                #
 
 
      BEGIN  # VLERROR #
 
#
**    VLERROR - ISSUE ERROR MESSAGE.
*
*     THE ERROR MESSAGE SPECIFIED BY *ERNUM* IS ISSUED TO THE
*     DAYFILE AND REPORT FILE (IF OPENED).  IF SELECTED, PARAMETERS
*     FROM THE *MPARAM* ARRAY MAY BE INSERTED INTO THE MESSAGE TEXT
*     FIRST.  ALSO, A DETAIL STATUS FROM *STAT* WILL BE ISSUED IF
*     SPECIFIED.  THE OPTIONS FOR A SPECIFIC ERROR ARE DEFINED
*     WITH THE ERROR MESSAGE TEXT (IN COMTVLD) AND RESIDE IN A
*     LOCAL ARRAY.
*
*     PROC VLERROR(ERNUM,ABTFLG)
*
*     ENTRY     (ABTFLG)       - ABORT FLAG (PROGRAM ABORTED IF TRUE)
*               (ERNUM)        - ERROR NUMBER (FROM STATUS LIST *VE*
*                                IN COMTVLD).
*               (RPTFADR)      - REPORT FILE *FET* ADDRESS (ZERO IF
*                                NOT OPENED).
*               (STAT)         - DETAIL STATUS VALUE (OPTIONAL).
*               (ARRAY MPARAM) - CONTAINS PARAMETERS FOR ERROR MESSAGE
*                                TEXT (OPTIONAL).
*
*     EXIT      (CNTPROGERR) - COUNT OF ERRORS.
*
*               THE ERROR MESSAGE IS ISSUED TO THE REPORT FILE IF THE
*               FILE IS OPENED.
*
*     MESSAGES  *   ** ERROR MESSAGE TEXT   *
*               *      DETAIL STATUS = NNN  * (OPTIONAL)
*
#
 
      ITEM ERNUM      I;             # ERROR NUMBER #
      ITEM ABTFLG     I;             # ABORT RUN FLAG #
 
#
****  PROC VLERROR - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC MESSAGE;                # INTERFACE TO *MESSAGE* MACRO #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT
                                       OR RETURN #
        PROC RPCLOSE;                # CLOSES A PRINT FILE #
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC VLMSG;                  # ISSUE INFORMATIONAL MESSAGE #
        FUNC VLNTC C(10);            # NUMERIC TO CHARACTER
                                       CONVERSION #
        PROC VLPFILL;                # FILL PARAMETER IN MESSAGE
                                       TEXT #
        END
 
#
****  PROC VLERROR - XREF LIST END.
#
 
      DEF LISTCON #0#;
 
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLF
 
      ITEM N          I;             # TEMPORARY VARIABLE #
      ITEM NP         I;             # TEMPORARY VARIABLE #
 
      ARRAY TEXT [0:0] S(5);         # TO FORMAT ERROR MESSAGE #
        BEGIN
        ITEM TEX$MSG    C(00,00,40);  # MESSAGE TEXT #
        ITEM TEX$LEAD   C(00,00,03);  # LEADING CODES #
        ITEM TEX$ZERO   U(04,00,60) = [ 0 ];  # ZERO BYTE #
        END
 
      ARRAY ERRCODES [0:0] S(1);     # ERROR OPTION CODES #
        BEGIN
        ITEM ERR$CODES  C(00,00,03);
        ITEM ERR$STAT   C(00,00,01);  # DETAIL STATUS FLAG #
        ITEM ERR$PARN   U(00,06,06);  # NUMBER OF PARAMETERS #
        END
 
 
      ARRAY DTLSTAT [0:0] S(5);      # DETAIL STATUS MESSAGE #
        BEGIN
        ITEM DTL$MSG    C(00,00,40) = ["   DETAIL STATUS = "];
        ITEM DTL$NUM    C(02,00,04);  # STATUS VALUE #
        ITEM DTL$ZERO   U(04,00,60) = [ 0 ];
        END
 
#
*     ARRAY OF DEFINED ERROR MESSAGE TEXTS.  WARNING - THE ORDER
*     OF THIS LIST IS DEPENDENT ON THE STATUS LIST "VE".
*     THE TEXTS ARE DEFINED IN *COMTVLD*.
#
 
      ARRAY ERRTEXT [0:VE"EREND"] S(4);  # ERROR MESSAGES ARRAY #
        BEGIN
        ITEM ERRMSG     C(00,00,40) = [ "   NO ERROR ",
        MSYNTAX,
        MSMPAR,
        MFXPAR,
        MSBPAR,
        MSTPAR,
        MLFRF,
        MRLNRF,
        MRFFM,
        MRFAM,
        MRDFH,
        MRDFL,
        MRDFU,
        MCATO,
        MCATR,
        MMAPO,
        MMAPR,
        MNOFL,
        MNCONN,
        MUCPERR,
        MNOFAM,
        MPFCER,
        MDUPSM,
        MDUPSB,
        MSYSERR,
        MABORT,
        "  " ];
        END
 
                                               CONTROL EJECT;
      CNTPROGERR = CNTPROGERR + 1;
 
#
*     SET UP THE MESSAGE TEXT BASED ON THE ERROR NUMBER.
#
 
      TEX$MSG[0] = ERRMSG[ERNUM];
      ERR$CODES[0] = TEX$LEAD[0];
 
#
*     INSERT PARAMETERS INTO TEXT IF SPECIFIED.
#
 
      IF ERR$PARN[0] NQ " "
      THEN                           # PARAMETERS SPECIFIED #
        BEGIN
        NP = ERR$PARN[0] - "0";      # CALCULATE THE NUMBER OF
                                       PARAMETERS #
        SLOWFOR N = 1 STEP 1 UNTIL NP
        DO
          BEGIN  # N #
          VLPFILL(TEXT,MPARAM[N]);   # MOVE PARAMETER TO TEXT #
          END  # N #
 
        END
 
#
*     ISSUE ERROR TEXT TO DAYFILE.
#
 
      TEX$LEAD[0] = " **";           # DAYFILE MSG MUST HAVE 1 BLANK #
      MESSAGE(TEXT,SYSUDF1);
 
#
*     ISSUE ERROR TEXT TO REPORT FILE, IF IT IS OPEN.
#
 
      IF RPTFADR NQ 0
      THEN
        BEGIN
        RPLINE(RPTFADR," ",0,1,EOPL);  # BLANK LINE #
        TEX$LEAD[0] = "***";         # ERROR FLAG #
        RPLINE(RPTFADR,TEXT,4,40,EOPL);  # ISSUE ERROR MESSAGE #
        END
 
#
*     ISSUE DETAIL STATUS, IF SPECIFIED.
#
 
      IF ERR$STAT[0] EQ "S"
      THEN
        BEGIN
        DTL$NUM[0] = VLNTC(STAT,"XCOD",4);  # SET NUMBER FROM *STAT* #
        MESSAGE(DTLSTAT,SYSUDF1);    # ISSUE DETAIL MESSAGE #
        IF RPTFADR NQ 0
        THEN
          BEGIN
          RPLINE(RPTFADR,DTLSTAT,4,40,EOPL);  # ISSUE TO REPORT FILE #
          END
 
        END
 
#
*     IF ABORT FLAG IS SET, ABORT.
#
 
      IF (ABTFLG EQ ABRT)
      THEN
        BEGIN
        IF (RPTFADR NQ 0)            # CLOSE REPORT FILE IF IT IS
                                       OPENED #
        THEN
          BEGIN
          RPCLOSE(RPTFADR);
          END
 
        VLMSG(VM"VLABT");            # ISSUE SSVAL ABORTED MESSAGE #
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT #
        END
 
      RETURN;
 
      END  # VLERROR #
 
    TERM
PROC VLFIX;
# TITLE VLFIX - FIX CATALOGS.                                         #
 
 
      BEGIN  # VLFIX #
 
#
**    VLFIX - FIX CATALOGS.
*
*     *VLFIX* READS THE FIXIT FILE AND MODIFIES THE CORRESPONDING
*     CATALOG ENTRIES DEPENDING UPON THE MODE SPECIFIED BY THE
*     CONTROL CARD PARAMETERS.
*
*     PROC VLFIX
*
*     ENTRY     (CNTORPHANS)    - COUNT OF TROUBLE-FREE ORPHANS.
*               (CONNECTED)     - CONNECTED TO *EXEC* FLAG.
*               (PAR$FX)        - FX CONTROL CARD PARAMETER.
*               (PAR$RF)        - RF CONTROL CARD PARAMETER.
*               (PAR$RL)        - RL CONTROL CARD PARAMETER.
*               (RDFDT)         - *RDF* FILE PACKED DATE AND TIME.
*               (RELEASABLE)    - COUNT OF RELEASABLE AU-S.
*               (TOTALERRS)     - TOTAL VALIDATION ERRORS.
*               (ARRAY FIXFILE) - FIXIT FILE *FET*.
*
*     EXIT      RELEASE PROCESSING OCCURRED IF MODE IS EQUAL TO
*               RELEASE.
*               REPAIR PROCESSING OCCURRED IF MODE IS EQUAL TO FIX.
*               INFORMATIONAL LINES WERE WRITTEN TO THE REPORT FILE.
*
*     MESSAGES  * TOTAL VALIDATION ERRORS = NNN *
*               * RELEASABLE M860 FILE = NNNN *
*               * RELEASABLE M860 AU-S = NNNN *
*               * CATALOGS NOT MODIFIED *
*               * CATALOGS MODIFIED *
*               * FREE FILES NOT RELEASED *
*               * FREE FILES RELEASED *
*
*     NOTES     THE MODES OF PROCESSING ARE -
*
*                 . RELEASE - RELEASE ORPHANS IN THE SFM CATALOG.
*                   THIS MODE IS SET IF -
*                     THE *RF* AND *RL* PARAMETERS WERE SPECIFIED AND
*                     THE *TOTALERRS* IS LESS THAN THE *FX* PARAMETER.
*
*                 . FIX - SET APPROPRIATE FLAGS IN THE CATALOGS FOR
*                   ERRORS DETECTED.
*                   THIS MODE IS SET IF -
*                     THE *FM* PARAMETER IS SET AND THE *TOTALERRS*
*                     IS LESS THAN THE *FX* PARAMETER.
*
*                 . NONE - NO CATALOG MODIFICATIONS.
*                   THIS MODE IS SET IF *SSVAL* IS NOT CONNECTED
*                   TO *EXEC* OR NOT IN FIX OR RELEASE MODE.
*
*               RELEASE OF FREE AU-S IN A SPECIFIC SUBCATALOG
*               OCCURS ONLY IF THE DATE AND TIME IN THE *RDF* FILE IS
*               MORE RECENT THAN THE LAST PURGE DATE AND TIME FOR THE
*               SUBCATALOG.
*
*               THE REPAIRS THAT *SSVAL* CAN PERFORM ARE DEFINED IN
*               THE ARRAY *FIXARRAY*.  THE REPAIRS TO BE TAKEN FOR
*               A SPECIFIC FIXIT FILE RECORD ARE DETERMINED BY THE
*               RECORD TYPE WHICH REFLECTS THE TYPE OF ERROR THAT
*               OCCURRED DURING VALIDATION.
*
#
 
#
****  PROC VLFIX - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC READ;                   # INTERFACE TO *READ* MACRO #
        PROC READW;                  # INTERFACE TO *READW* MACRO #
        PROC RETERN;                   # RETURN LOCAL FILE #
        PROC REWIND;                 # INTERFACE TO *REWIND* MACRO #
        PROC RPEJECT;                # STARTS A NEW REPORT PAGE #
        PROC VLFIXP;                 # CONNECTS *PF* AND SETS *ASA* #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC VLLPDT;                 # GET LAST PURGE DATE AND TIME #
        PROC VLMSG;                  # ISSUE INFORMATIONAL MESSAGE #
        FUNC VLNTC C(10);            # NUMERIC TO CHARACTER
                                       CONVERSION #
        PROC VLREQEX;                # REQUEST TO EXEC #
        PROC WRITEW;                   # WRITE TO WORKING BUFFER #
        PROC WRITEF;                 # INTERFACE TO *WRITEF* MACRO #
        END
 
#
****  PROC VLFIX - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
*CALL COMBCPR
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLV
 
      STATUS PROCTYP                 # PROCESSING TYPE #
        NONE,
        FIX,                         # FIX CATALOGS #
        RELEASE,                     # RELEASE FILE SPACE #
        PTEND;
 
      DEF FREE #0#;                  # SET FREE FLAG IN PFC #
      DEF ZERO #1#;                  # ZERO *PFC* ASA #
 
      ITEM FREFL   B;                # FREE CARTRIDGE FLAG SET #
      ITEM MODE       S : PROCTYP = S"NONE";  # MODE FOR FIX PROCESS #
      ITEM LPDT       U;             # LAST PURGE DATE-TIME #
      ITEM FIXACTION  I;             # FIX ACTIONS FOR FIXIT RECORD #
      ITEM RDF$BEFORE B;             # RDF BEFORE PURGE DATE #
      ITEM RELEASED   B;             # FREE FILES RELEASED FLAG #
 
#
*     ACTION FLAGS TO DEFINE THE CATALOG REPAIRS THAT *SSVAL* CAN
*     PERFORM.
#
 
      DEF ACT$NONE   #O"000000"#;    # NO ACTION #
      DEF ACT$UMAP   #O"000001"#;    # UPDATE SMMAP #
      DEF ACT$UPFC   #O"000010"#;    # UPDATE *PFC* ENTRY #
      DEF ACT$USM    #O"000100"#;    # UPDATE *SM* FLAG IN SFM
                                       CATALOG #
      DEF ACT$UFROZ  #O"001000"#;    # UPDATE FROZEN AU FLAG #
      DEF ACT$USOF   #O"010000"#;    # UPDATE *SOF* AU FLAG #
      DEF ACT$INHIB  #O"100000"#;    # SET INHIBIT FLAG IN *FCT* #
      DEF ACT$P$F$S  #O"011010"#;
      DEF ACT$F$S    #O"011000"#;    # MULTIPLE ACTIONS #
      DEF ACT$UC$INH #O"100100"#;    # MULTIPLE ACTIONS #
      DEF ACT$UF$UI  #O"101000"#;    # MULTIPLE ACTIONS #
 
#
*      *CPR* WORKING BUFFER.
#
 
      ARRAY CPRARRAY [0:0] S(CPRLEN);;
 
 
#
*     DEFINE ACTIONS TO TAKE FOR THE VARIOUS FIXIT FILE RECORD TYPES.
*     DURING THE VALIDATION PROCESS, RECORDS WERE WRITTEN TO THE FIXIT
*     FILE FOR PROBLEMS DETECTED.  THE RECORD TYPE REFLECTS THE TYPE OF
*     REPAIR PROCESSING TO BE DONE.
#
 
      ARRAY FIXARRAY [0:REC"REND"] S(1);  # FIX ACTIONS FOR FIX
                                            RECORDS #
        BEGIN
        ITEM FIXA$WD    U(00,00,60);
        ITEM FIXA$TFO   U(REC"TFORPH",0,60) = [ACT$NONE];
        ITEM FIXA$FCT   U(REC"FCT",0,60) = [ACT$UC$INH];
        ITEM FIXA$SM    U(REC"SM",0,60) = [ACT$UMAP];
        ITEM FIXA$ASA   U(REC"ASA",0,60) = [ACT$UPFC];
        ITEM FIXA$PFC   U(REC"OTHR",0,60) = [ACT$P$F$S];
        ITEM FIXA$ORPH  U(REC"BADORPH",0,60) = [ACT$UFROZ];
        ITEM FIXA$FRAG  U(REC"FRAG",0,60) = [ACT$F$S];
      ITEM FIXA$HOLE  U(REC"BADHOLE",0,60) = [ACT$UF$UI];
        END
 
                                               CONTROL EJECT;
 
#
*     CLOSE THE FIXIT FILE.
#
 
      FREFL = FALSE;
      WRITEF(FIXITFILE,RCL);
      REWIND(FIXITFILE,RCL);
 
#
*     ISSUE COUNT OF ORPHANS.
#
 
      MP$WD[1] = VLNTC(CNTORPHANS,"XCDD",5);
      VLMSG(VM"NTFO");
 
#
*     ISSUE COUNT OF RELEASABLE AU-S.
#
 
      MP$WD[1] = VLNTC(RELEASABLE,"XCDD",6);
      VLMSG(VM"RSPACE");
 
#
*     ISSUE NUMBER OF PFC SYSTEM AND DATA ERRORS.
#
 
      IF TPFCERRS NQ 0
      THEN
        BEGIN
        MP$WD[1] = VLNTC(TPFCERRS,"XCDD",4);
        VLMSG(VM"TPFCER");
      END
 
#
*     ISSUE NUMBER OF VALIDATION ERRORS.
#
 
      MP$WD[1] = VLNTC(TOTALERRS,"XCDD",4);
      VLMSG(VM"TOTERR");
 
#
*     IF NOT CONNECTED TO EXEC, NO FIX/RELEASE PROCESSING CAN BE DONE.
#
 
      IF NOT CONNECTED
      THEN
        BEGIN
        VLMSG(VM"NOFIX");            # ISSUE MESSAGE #
        RETURN;
        END
 
#
*     DETERMINE MODE OF FIX PROCESSING BASED ON CONTROL CARD
*     PARAMETERS AND VALIDATION TOTAL ERRORS.
#
 
      IF (PAR$RF EQ 0) AND (TOTALERRS LQ PAR$FX)
        AND (TOTALERRS NQ 0)
      THEN
        BEGIN
        VLMSG(VM"UPDED");            # ISSUE MESSAGE #
        MODE = S"FIX";               # FIX CATALOG MODE #
        END
 
      IF (PAR$RF NQ 0) AND (PAR$RL NQ 0) AND (TOTALERRS LQ PAR$FX)
      THEN
        BEGIN
        RELEASED = FALSE;            # INITIALIZE FILES RELEASED FLAG #
        RDF$BEFORE = FALSE;          # INITIALIZE RDF FLAG #
        MODE = S"RELEASE";           # RELEASE ORPHANS MODE #
        END
 
      IF MODE EQ S"NONE"
      THEN
        BEGIN
        VLMSG(VM"NOFIX");            # ISSUE MESSAGE #
        END
 
 
#
*     READ THE FIXIT FILE AND PERFORM FIX/RELEASE ACTIONS BASED ON
*     RECORD TYPE.
#
 
      READ(FIXITFILE,NRCL);
      STAT = OK;
      REPEAT WHILE STAT EQ OK
      DO
        BEGIN  # PROCESS FIXIT FILE #
        READW(FIXITFILE,EXTRECORD,RLFIX,STAT);
        IF STAT NQ 0
        THEN
          BEGIN
          TEST DUMMY;                # EXIT, NO RECORD TO PROCESS #
          END
 
        SMINDX = EXTR$SM[0];
        SBINDX  = EXTR$SB[0];
 
#
*     FOR RELEASE MODE, PURGE TROUBLE-FREE ORPHANS.
#
 
        IF (MODE EQ S"RELEASE") AND (FIX$RT[0] EQ REC"TFORPH")
        THEN
          BEGIN  # RELEASE ORPHANS #
          VLLPDT(EXTR$SB[0],EXTR$SM[0],LPDT);  # RETURNS LAST PURGE
                                                  DATE/TIME #
 
#
*     RELEASE ONLY IF THE SUBCATALOG LAST PURGE DATE/TIME IS LESS THAN
*     THE RDF FILE DATE/TIME.
#
 
          IF LPDT LS RDFDT
          THEN
            BEGIN
#
*     CONVERT TO *CPR* FORMAT.
#
 
            P<CPR> = LOC(CPRARRAY);
            CPR$C[0] = FALSE;
            CPR$CSU[0] = EXTR$SM[0];
            CPR$SUB[0] = EXTR$SB[0];
            CPR$FAM[0] = PAR$FM;
            CPR$FCT[0] = EXTR$FCT[0];
            CPR$AU[0] = EXTR$AU[0];
            CPR$RQT[0] = TYP"TYP3";
            CPR$RQC[0] = REQTYP3"REL$SETUP";
            WRITEW(RELCFILE,CPRARRAY,CPRLEN,STAT);
            RELEASED = TRUE;         # FREE FILES RELEASED #
            TEST DUMMY;
            END
 
          ELSE
            BEGIN
            RDF$BEFORE = TRUE;
            END
 
          END  # RELEASE ORPHANS #
 
#
*     UPDATE *PFC* IF FILE IS TO BE REMOVED FROM CARTRIDGE.
#
 
      IF FIX$RT[0] EQ REC"FCF"
        AND PAR$RF EQ 0
      THEN                   # SET FREE CARTRIDGE FLAGS #
        BEGIN
        VLFIXP(FREE);
        IF STAT EQ 0
        THEN
          BEGIN
          FREFL = TRUE;
          END
 
        END
 
 
#
*     FOR FIX MODE, GET ACTIONS BASED ON THE FIXIT RECORD TYPE.
#
 
        IF MODE NQ S"FIX"
        THEN
          BEGIN
          TEST DUMMY;                # SKIP IF NOT FIX MODE #
          END
 
        FIXACTION = FIXA$WD[FIX$RT[0]];  # ACTIONS FOR THIS RECORD #
 
#
*     UPDATE THE SMMAP ENTRY.
#
 
        IF FIXACTION LAN ACT$UMAP NQ 0
        THEN
          BEGIN
          VLREQEX(TYP"TYP3",REQTYP3"UPD$MAP");
          END
 
#
*     UPDATE *PFC* ENTRY IF THE FILE HAS A DISK IMAGE.
#
 
        IF FIXACTION LAN ACT$UPFC NQ 0 AND EXTR$D[0] NQ 0
        THEN
          BEGIN
          VLFIXP(ZERO);
          END
 
#
*     UPDATE THE SFM CATALOG SMERR FLAG.
#
 
        IF FIXACTION LAN ACT$USM NQ 0
        THEN
          BEGIN
          CFIELD = UCF"CMAP";        # CHANGE SMERR FLAG #
          VLREQEX(TYP"TYP3",REQTYP3"UPD$CAT");
          END
 
#
*     UPDATE INHIBIT FLAG IN FCT.
#
 
        IF FIXACTION LAN ACT$INHIB NQ 0
          OR (FIXACTION LAN ACT$UFROZ NQ 0
          AND NOT VTEN$ALOC[0])
        THEN
          BEGIN
          CFIELD = UCF"INHIB";       # CHANGE INHIBIT FLAG #
          VLREQEX(TYP"TYP3",REQTYP3"UPD$CAT");
          END
 
#
*     UPDATE SFM CATALOG *FCT* AU FROZ FLAG.
#
 
        IF FIXACTION LAN ACT$UFROZ NQ 0
        THEN
          BEGIN
          CFIELD = UCF"FROZ";        # CHANGE FROZ FLAG #
          VLREQEX(TYP"TYP3",REQTYP3"UPD$CAT");
          END
 
#
*     UPDATE SFM CATALOG *FCT* AU *SOF* FLAG IF THE ENTRY IS
*     A START OF FRAGMENT.
#
 
        VTEN$WORD[0] = FIX$VT[0];    # GET *VT* ENTRY FROM RECORD #
        IF FIXACTION LAN ACT$USOF NQ 0 AND VTEN$SOF[0]
        THEN
          BEGIN
          CFIELD = UCF"SOF";         # CHANGE *SOF* FLAG #
          VLREQEX(TYP"TYP3",REQTYP3"UPD$CAT");
          END
 
        END  # PROCESS FIXIT FILE #
 
      IF RELEASED AND MODE EQ S"RELEASE"
      THEN
        BEGIN
        WRITEF(RELCFILE,RCL);
        RETERN(RELCFILE,RCL);
        VLMSG(VM"REL");
        VLREQEX(TYP"TYP3",REQTYP3"REL$SETUP");
        MP$WD[1] = VLNTC(NFILER,"XCDD",5);
        VLMSG(VM"FCREL");
        END
 
      IF NOT RELEASED AND MODE EQ S"RELEASE"
      THEN
        BEGIN
        VLMSG(VM"FSNREL");
        IF RDF$BEFORE
        THEN
          BEGIN
          VLMSG(VM"RDFBF");
          END
 
        END
 
      IF FREFL
      THEN                           # FREE CARTRIDGE FLAG SET #
        BEGIN
        VLMSG(VM"FFSET");
        END
 
 
      END  # VLFIX #
 
    TERM
PROC VLFIXP(ACTION);
# TITLE VLFIXP - ATTACHES PERMANENT FILE AND RESETS THE ASA.          #
 
      BEGIN  # VLFIXP #
 
#
**    VLFIXP - RESETS THE *ASA*.
*
*     *VLFIXP* ATTACHES THE USER FILE SPECIFIED IN THE FIXIT
*     FILE ENTRY, VERIFIES THE *ASA* IS CORRECT, RESETS THE
*     *ASA*, THEN RETURNS THE FILE.
*
*     PROC VLFIXP
*
*     ENTRY     (PAR$FM)        - FAMILY.
*               (ACTION) IF ZERO THEN SET FREE FLAG IN *PFC*, ELSE
*                        ZERO *ASA* IN *PFC*.
*               ARRAY EXTRECORD - FIXIT FILE RECORD.
*
*     EXIT      THE *ASA* FOR THE FIXIT FILE ENTRY IS SET TO ZERO.
*               THE USER FILE IS RETURNED.
#
 
#
****  PROC VLFIXP - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC BZFILL;                 # ZERO FILL STORAGE #
        PROC MESSAGE;                # SEND MESSAGE TO DAYFILE #
        PROC SETAF;                  # SET FLAG IN *PFC* #
        PROC RECALL;                 # INTERFACE TO RECALL #
        PROC RETERN;                 # RETURNS SPECIFIED FILE #
        PROC SETASA;                 # INTERFACE TO *SETASA* ROUTINE #
        PROC UATTACH;                # INTERFACE TO *UATTACH* MACRO #
        PROC UGET;                   # UTILITY GET #
        END
 
#
****  PROC VLFIXP - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
*CALL COMBBZF;
*CALL COMSPFM
*CALL COMTVLD
*CALL COMTVLF
 
      DEF ACCMD      #1#;            # READ MODE #
      DEF RP  #4#;                   # FULL ERROR PROCESSING #
      DEF ZEROASA    #0#;            # ZERO THE *ASA* #
 
      ITEM ACTION     U;             # ZERO OR SET FLAG #
      ITEM FAMILY     C(10);         # FAMILY NAME #
      ITEM I          U;             # INDUCTION VARIABLE #
      ITEM J          U;             # INDUCTION #
      ITEM LFN        C(10);         # LOCAL FILE NAME #
      ITEM PFNM       C(10);         # PERMANENT FILE NAME #
      ITEM UFLAG      U;             # STATUS FLAG #
 
      ARRAY PFCCAT [0:0] S(16);      # TEMPORARY ARRAY FOR *PFC* #
        BEGIN
        ITEM NOITEM     U(00,00,60);  # DUMMY ITEM #
        END
 
      ARRAY MSSGE[0:2];;             # ARRAY FOR MESSAGE #
 
      ARRAY MSSG [0:0] P(2);
        BEGIN
        ITEM MSSG1 C(00,00,13);  # ARRAY FOR MESSAGE #
        END
 
                                               CONTROL EJECT;
 
#
*     SET ADDRESS FOR BASED ARRAY, *PFC*.
#
 
      P<PFC> = LOC(PFCCAT);
 
 
#
*     ATTACH THE PERMANENT FILE.
#
 
      LFN = UTTLFN;
      BZFILL(LFN,TYPFILL"ZFILL",10);
      PFNM= EXTR$PFNC[0];
      BZFILL(PFNM,TYPFILL"ZFILL",10);
      FAMILY = PAR$FM;
      BZFILL(FAMILY,TYPFILL"ZFILL",10);
 
#
*     SET THE FREE FLAG IF ACTION = 0.
#
 
      IF ACTION EQ 0
      THEN                        # SET *AFFRE* FLAG IN *PFC* #
        BEGIN
        SETAF(LFN,STAT,RP,EXTR$UI[0],FAMILY,EXTR$PFID[0],        ##
          EXTR$ATASA[0],EXTR$CREA[0],AFFRE,MSSGE[0]);
        RETURN;
        END
 
#
*     MAKE FILE LOCAL BEFORE SETASA.
#
 
      IF EXTR$DA[0]
      THEN                           # DIRECT ACCESS FILE #
        BEGIN
        UATTACH(LFN,STAT,RP,PFNM,ACCMD,EXTR$UI[0],FAMILY, ##
          EXTR$PFID[0],PFCCAT[0],EXTR$CREA[0],MSSGE[0]);
        END
 
      ELSE                           # INDIRECT ACCESS FILE #
        BEGIN
        UFLAG = -1;
        SLOWFOR I = 0 WHILE UFLAG NQ 0
        DO
          BEGIN                      # WAIT FOR UGET RESPONSE #
          UFLAG = -1;
          UGET(LFN,UFLAG,6,PFNM,EXTR$UI[0],FAMILY,EXTR$PFID[0], ##
            PFCCAT[0],EXTR$CREA[0],MSSGE[0]);
 
          IF UFLAG EQ PEA            # EXCESS ACTIVITY #
            OR UFLAG EQ INA          # NO INTERLOCK #
          THEN
            BEGIN
            TEST I;
            END
 
          IF UFLAG NQ 0
          THEN
            BEGIN
            MSSG1 = " UGET FAILED.";
            MESSAGE(MSSG,UDFL1);
            UFLAG = 0;
            END
 
          END                        # WAIT FOR UGET REQUEST #
 
        END
 
 
#
*     IF THERE WAS NO ERROR, AND IF THE CATALOG MAP *ASA*
*     MATCHES THE EXTRACT FILE *ASA*,
*     THEN -
*     RESET THE *ASA* TO ZERO USING THE *SETASA* MACRO.
#
 
      IF (STAT EQ 0) AND (PFC$AA[0] EQ EXTR$ASA[0])
        AND UFLAG EQ 0
        AND ACTION EQ 1
      THEN
        BEGIN
        SETASA(LFN,STAT,RP,EXTR$UI[0],FAMILY,EXTR$PFID[0]  ##
          ,ZEROASA,EXTR$CREA[0],MSSGE[0]);
        END
 
      RETERN(UTTLFN,RCL);
      END  # VLFIXP #
 
    TERM
PROC VLLPDT(SUBPAR,SMPAR,LPDT);
# TITLE VLLPDT - GET LAST PURGE DATE AND TIME.                        #
 
 
      BEGIN  # VLLPDT #
 
#
**    VLLPDT - GET LAST PURGE DATE AND TIME.
*
*     *VLLPDT* ISSUES A REQUEST TO *EXEC* TO GET THE "LAST
*     PURGE DATE AND TIME" FOR THE SUBCATALOG FROM THE
*     PREAMBLE IN THE SFM CATALOG FOR THE SPECIFIED SUBFAMILY.
*
*     PROC VLLPDT(SUBPAR,SMPAR,LPDT)
*
*     ENTRY     (SUBPAR) - SUBFAMILY.
*               (SMPAR) - *SM* DESIGNATOR.
*
*     EXIT      (LPDT) - PACKED DATE AND TIME RETURNED FROM *EXEC*.
#
 
      ITEM SUBPAR     I;             # SUBFAMILY #
      ITEM SMPAR      I;             # *SM* ID #
      ITEM LPDT       I;             # LAST PURGE DATE-TIME #
 
#
****  PROC VLLPDT - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC VLREQEX;                # REQUEST TO EXEC #
        END
 
#
****  PROC VLLPDT - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF LISTING #
 
*CALL COMBFAS
*CALL COMBCPR
*CALL COMTVLD
*CALL COMTVLF
 
      ITEM CURRSB     I = 0;         # CURRENT SUBFAMILY #
      ITEM CURRSM     I;             # CURRENT *SM* #
      ITEM CURRLPDT   I;             # CURRENT LPDT #
                                               CONTROL EJECT;
 
#
*     CALL *EXEC* TO GET THE LAST PURGE DATE/TIME FOR THE SUBCATALOG,
*     IF IT IS NOT CURRENT.
#
 
      IF (CURRSB NQ SUBPAR) OR (CURRSM NQ SMPAR)
      THEN
        BEGIN
        CURRSB = SUBPAR;             # SAVE CURRENT SUBFAMILY #
        CURRSM = SMPAR;            # SAVE CURRENT *SM* #
        VLREQEX(TYP"TYP3",REQTYP3"GT$PRGDATE");
        CURRLPDT = CPR$DATE[0];      # SAVE LAST PURGE DATE/TIME #
        END
 
#
*     RETURN THE LAST PURGE DATE/TIME FOR THE SUBCATALOG.
#
 
      LPDT = CURRLPDT;
 
      END  # VLLPDT #
 
    TERM
PROC VLMSG(MNUM);
# TITLE VLMSG - ISSUE INFORMATIONAL MESSAGE.                          #
 
      BEGIN  # VLMSG #
 
#
**    VLMSG - ISSUE INFORMATIONAL MESSAGE.
*
*     *VLMSG* ISSUES A SPECIFIED MESSAGE TO THE DAYFILE AND/OR
*     TO THE REPORT FILE.
*
*     PROC VLMSG(MNUM)
*
*     ENTRY     (MNUM)         - MESSAGE NUMBER FROM STATUS LIST *VM*.
*               (ARRAY MPARAM) - CONTAINS PARAMETER(S) TO INSERT IN
*                                THE MESSAGE TEXT.
*
*     EXIT      THE MESSAGE IS ISSUED.
*
*     NOTES     OPTIONS ARE SELECTED BY THE FIRST THREE
*               CHARACTERS OF THE MESSAGE TEXT.  OPTIONS ARE -
*               . MSG$SYS (B) -  ISSUES TO THE DAYFILE OR TO THE *B*
*                 DISPLAY LINE 2.
*               . MSG$RPT (Y) - ISSUES TO THE REPORT FILE.
*               . NUMBER OF PARAMETERS TO FILL IN THE MESSAGE TEXT
*                 FROM THE *MPARAM* ARRAY (NUMERIC, NOT A CHARACTER).
#
 
      ITEM MNUM       I;
 
#
****  PROC VLMSG - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC MESSAGE;                # INTERFACE TO *MESSAGE* MACRO #
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC VLPFILL;                # FILL PARAMETER IN MESSAGE
                                       TEXT #
        END
 
#
****  PROC VLMSG - XREF LIST END.
#
 
      DEF LISTCON #0#;
 
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLF
 
      ITEM NP         I;             # NUMBER OF PARAMETERS #
      ITEM N          I;             # TEMPORARY VARIABLE #
 
#
*     ARRAY TO FORMAT THE MESSAGE TO ISSUE.
#
 
      ARRAY VMTEXT [0:0] S(5);
        BEGIN
        ITEM VMT$LINE   C(00,00,40);
        ITEM VMT$LEAD   C(00,00,03);  # LEADING CODE CHARACTERS #
        ITEM VMT$TEXT   C(00,18,37);  # MESSAGE TEXT #
        ITEM VMT$ZERO   U(04,00,60);  # ZERO BYTE #
        END
 
#
*     ANALYZES ACTIONS TO DO BASED ON THE MESSAGE.
#
 
      ARRAY MSGCODES [0:0] S(1);     # MESSAGE CODES #
        BEGIN
        ITEM MSG$CODES  C(00,00,03);
        ITEM MSG$SYS    C(00,00,01);  # ISSUE TO SYSTEM MACRO #
        ITEM MSG$RPT    C(00,06,01);  # ISSUE TO REPORT FILE #
        ITEM MSG$PARN   U(00,12,06);  # NUMBER OF PARAMETERS TO INSERT
                                      #
        END
 
                                               CONTROL EJECT;
 
#
*     GET CODES FROM MESSAGE TEXT.
#
 
      VMT$LINE[0] = VMESS$LINE[MNUM];  # GET MESSAGE TEXT REQUESTED #
      MSG$CODES[0] = VMT$LEAD[0];    # EXTRACT CODES FROM TEXT #
      VMT$LEAD[0] = "   ";           # CLEAR CODES FIELD IN TEXT #
 
#
*     PUT PARAMETER(S) INTO MESSAGE IF THE NUMBER OF PARAMETERS IS
*     SPECIFIED IN CODES.
#
 
      IF MSG$PARN[0] NQ " "
      THEN
        BEGIN
        NP = MSG$PARN[0] - "0";      # NUMBER CONVERTED TO BINARY #
        SLOWFOR N = 1 STEP 1 UNTIL NP
        DO
          BEGIN
          VLPFILL(VMTEXT,MPARAM[N]);  # MOVE PARAMETER INTO TEXT #
          END
 
        END
 
#
*     ISSUE MESSAGE REQUEST TO THE SYSTEM IF SPECIFIED.
#
 
      IF MSG$SYS[0] NQ "N"
      THEN
        BEGIN  # ISSUE TO SYSTEM #
        IF MSG$SYS[0] EQ "B"
        THEN
          BEGIN
          MESSAGE(VMT$TEXT[0],LINE2);  # B ONLY #
          END
 
        ELSE
          BEGIN
          IF MSG$SYS[0] EQ "S"
          THEN
            BEGIN
            MESSAGE(VMT$TEXT[0],SYSUDF1);
            END
 
          ELSE
            BEGIN
            MESSAGE(VMT$TEXT[0],UDFL1);
            END
 
          END
 
        END  # ISSUE TO SYSTEM #
 
#
*     ISSUE MESSAGE TO THE REPORT FILE IF REQUESTED.
#
 
      IF MSG$RPT[0] NQ "N"
      THEN
        BEGIN
        RPLINE(RPTFADR," ",0,1,EOPL);  # BLANK LINE #
        RPLINE(RPTFADR,VMT$TEXT[0],3,37,EOPL);  # ISSUE TO REPORT #
        END
 
      END  # VLMSG #
 
    TERM
PROC VLNCS;
# TITLE VLNCS - NORMAL CHAIN SCAN.                                    #
 
 
      BEGIN  # VLNCS #
 
#
**    VLNCS - NORMAL CHAIN SCAN.
*
*     *VLNCS* SCANS ALL ENTRIES IN THE *VT* TABLE LOCATING
*     AND MARKING NORMAL CHAINS.  THE CHAIN IS SEARCHED
*     BEGINNING WITH THE HEAD OF CHAIN ENTRY AND PROCEEDING
*     THROUGH THE LINKAGE UNTIL *EOC* OR AN ERROR IS DETECTED.
*     ALL ENTRIES ON A CHAIN ARE MARKED BY SETTING THE POINTER
*     FIELD TO THE INDEX OF THE HEAD OF CHAIN (*HOC*) ENTRY.
*     FLAGS ARE SET IN THE *VT* ENTRIES FOR ERRORS DETECTED.
*
*     PROC VLNCS
*
*     ENTRY     (PAR$ST)      - SCATTER FILE PARAMETER.
*               (VTFIRST)     - INDEX OF FIRST ENTRY IN *VT*.
*               (VTLAST)      - INDEX OF LAST ENTRY IN *VT*.
*               (ARRAY VTTAB) - VALIDATION TABLE.
*
*     EXIT      THE FOLLOWING FIELDS IN THE *VT* ENTRY MAY BE UPDATED.
*               (VTEN$POINT) - INDEX OF THE *HOC* ENTRY.
*               (VTEN$ILL)   - ILL-FORMED CHAIN.
*               (VTEN$INTC)  - INTERSECTING CHAIN.
*               (VTEN$INTS)  - INTERSECTING AU.
*               (VTEN$SCAT)  - SCATTERED FILE.
*
*               INTERSECTING CHAIN DETAIL LINES ARE ISSUED TO THE
*               REPORT FILE IF INTERSECTIONS ARE DETECTED.
*
*     NOTES     CHAINS ARE FOLLOWED UNTIL -
*               . AN END OF CHAIN ENTRY IS DETECTED.
*               . AN ILL-FORMED CHAIN IS DETECTED.
*               . AN INTERSECTING CHAIN IS DETECTED.
*
*               ILL-FORMED CHAINS ARE THOSE WHICH HAVE A MEMBER
*               THAT LINKS TO AN ENTRY ON THIS CHAIN (LOOPING)
*               OR THAT LINKS TO AN UNALLOCATED ENTRY OR HAS A
*               LINK THAT IS NOT ZERO WHEN THE *EOC* FLAG IS SET.
*
*               INTERSECTING CHAINS ARE THOSE THAT HAVE A MEMBER
*               THAT LINKS TO AN ENTRY ON A DIFFERENT CHAIN.
*
*               A SCATTERED FILE CHECK IS PERFORMED.  THE SCATTERED
*               FLAG IS SET IF THE NUMBER OF CARTRIDGES FOR THE
*               CHAIN IS GREATER THAN THE *ST* PARAMETER.
*
#
 
#
****  PROC VLNCS - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC VLBICT;                 # INTERSECTING CHAIN REPORT #
        END
 
#
****  PROC VLNCS - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLV
 
 
      STATUS CHAIN                   # CHAIN STATUS #
        OK,                          # GOOD CHAIN #
        ILL,                         # ILL-FORMED CHAIN #
        INTC;                        # INTERSECTING CHAIN #
 
      ITEM ENDCHAIN   B;             # END OF CHAIN FLAG #
      ITEM FREESTAT   B;             # FREE FLAG STATUS #
      ITEM HOCSTAT    S : CHAIN;     # HEAD-OF-CHAIN STATUS #
      ITEM I          I;             # TEMPORARY VARIABLE #
      ITEM AUCNT      I;             # COUNT OF AU-S IN CHAIN #
      ITEM CARTCNT    I;             # COUNT OF CARTRIDGES IN CHAIN #
 
                                               CONTROL EJECT;
 
#
*     SCAN *VT* FOR *HOC* ENTRIES.
#
 
      SLOWFOR I = VTFIRST STEP 1 UNTIL VTLAST
      DO
        BEGIN  # *VT* SCAN #
        VTEN$WORD[0] = VT$ITEM[I];   # GET ENTRY #
 
        IF NOT VTEN$HOC[0]           # SKIP IF NOT HEAD OF CHAIN #
        THEN
          BEGIN
          TEST I;
          END
 
 
        VTPTR = I;                   # SET TO HEAD OF CHAIN #
 
 
#
*     INITIALIZE.
#
 
        AUCNT = 0;
        CARTCNT = 1;
        ENDCHAIN = FALSE;
        FREESTAT = FALSE;
        HOCSTAT = S"OK";             # ASSUME GOOD #
 
#
*     PROCESS EACH ENTRY IN THE CHAIN STARTING WITH HEAD OF CHAIN.
*     NOTE - ENTRIES ARE PLACED ON A CHAIN BY SETTING THE VTEN$POINT
*            FIELD EQUAL TO THE INDEX FOR THE HEAD OF CHAIN.
*            I = HEAD OF CHAIN INDEX.
#
 
        REPEAT WHILE NOT ENDCHAIN
        DO                           # NORMAL CHAIN PROCESS #
          BEGIN  # NOT END OF CHAIN #
          IF VTEN$POINT[0] EQ 0
          THEN
 
#
*     PUT ENTRY ON CHAIN.
#
 
            BEGIN  # ADD TO CHAIN #
            VTEN$POINT[0] = I;       # MARK ENTRY ON CHAIN #
            IF NOT VTEN$ALOC[0]
            THEN
              BEGIN
              VTEN$SOF[0] = TRUE;
              END
 
            IF NOT VTEN$ALOC[0] OR VTEN$EOC[0] AND VTEN$LINK[0] NQ 0
              THEN
              BEGIN
              HOCSTAT = S"ILL";      # ILL-FORMED CHAIN #
              END
 
            AUCNT = AUCNT + 1;
            IF VTEN$OCL[0] NQ 0
            THEN                     # LINK IS OFF CARTRIDGE #
              BEGIN
              CARTCNT = CARTCNT + 1;
              END
 
            IF VTEN$FCF[0]
            THEN                     # FREE CARTRIDGE FLAG SET #
              BEGIN
              FREESTAT = TRUE;
              END
 
            END  # ADD TO CHAIN #
 
          ELSE                       # VTEN$POINT[0] NOT EQUAL TO 0 #
 
#
*     ENTRY ALREADY ASSIGNED TO A CHAIN.
#
 
            BEGIN  # ENTRY ON A CHAIN #
            VTEN$INTS[0] = TRUE;
            IF VTEN$POINT[0] EQ I
            THEN
              BEGIN
              HOCSTAT = S"ILL";      # ILL-FORMED CHAIN #
              VTEN$LOOP[0] = TRUE;
              END
 
            ELSE
              BEGIN
              HOCSTAT = S"INTC";     # INTERSECTING CHAIN #
              VLBICT(I,VTEN$POINT[0]);  # REPORT INTERSECTIONS #
              END
 
            END  # ENTRY ON A CHAIN #
 
#
*     UPDATE AU ENTRY.
#
 
          VT$ITEM[VTPTR] = VTEN$WORD[0];  # STORE ENTRY TO *VT* #
 
#
*     DETERMINE IF END-OF-CHAIN.  THE END IS WHEN THE END OF CHAIN
*     FLAG IS SET OR A CHAIN WITH LINKAGE PROBLEMS HAS BEEN DETECTED.
#
 
          ENDCHAIN = VTEN$EOC[0] OR HOCSTAT NQ 0;
 
#
*     GET LINK TO NEXT IF NOT AT END.
#
 
          IF NOT ENDCHAIN
          THEN
            BEGIN  # LINK TO NEXT #
            VTPTR = VTEN$LINK[0];
            IF (VTPTR LS VTFIRST) OR (VTPTR GR VTLAST)
            THEN                     # BAD LINK #
              BEGIN
              HOCSTAT = S"ILL";      # ILL-FORMED CHAIN #
              ENDCHAIN = TRUE;
              END
 
            END  # LINK TO NEXT #
 
 
#
*     GET NEXT AU IN CHAIN.
#
 
          IF NOT ENDCHAIN
          THEN
            BEGIN
            VTEN$WORD[0] = VT$ITEM[VTPTR];  # NEXT AU #
            END
 
          END  # NOT END OF CHAIN #
 
#
*     IF INTERSECTING CHAINS, UPDATE OTHER *HOC* ENTRY.
#
 
        IF HOCSTAT EQ S"INTC"
        THEN
          BEGIN
          VTEN$WORD[0] = VT$ITEM[VTEN$POINT[0]];  # GET *HOC* ENTRY #
          VTEN$INTC[0] = TRUE;       # SET INTERSECTING #
          VT$ITEM[VTEN$POINT[0]] = VTEN$WORD[0];  # STORE *HOC* ENTRY #
          END
 
#
*     UPDATE THE *HOC* ENTRY.
#
 
        VTEN$WORD[0] = VT$ITEM[I];   # GET *HOC* ENTRY #
        IF HOCSTAT EQ S"ILL"
        THEN
          BEGIN
          VTEN$ILL[0] = TRUE;        # SET ILL-FORMED BIT #
          END
 
        IF HOCSTAT EQ S"INTC"
        THEN
          BEGIN
          VTEN$INTC[0] = TRUE;       # SET INTERSECTING BIT #
          END
 
#
*     DO SCATTERED FILE CHECK.
#
 
        IF CARTCNT GR PAR$ST
        THEN
          BEGIN
          VTEN$SCAT[0] = TRUE;       # SET SCATTERED BIT #
          END
 
        IF FREESTAT
        THEN                         # FREE CARTRIDGE FLAG WAS SET #
          BEGIN
          VTEN$FCF[0] = TRUE;
          END
 
        VT$ITEM[I] = VTEN$WORD[0];   # STORE *HOC* ENTRY #
 
        END  # *VT* SCAN #
 
      END  # VLNCS #
 
    TERM
FUNC VLNTC((FLD),(CONVTYP),(SIZE)) C(10);
# TITLE VLNTC - NUMERIC TO CHARACTER CONVERSION.                      #
 
      BEGIN  # VLNTC #
 
#
**    VLNTC - NUMERIC TO CHARACTER CONVERSION.
*
*     *VLNTC* CONVERTS THE DECIMAL/OCTAL NUMERIC TYPE DATA FIELD
*     INTO A LEFT-JUSTIFIED CHARACTER TYPE FIELD.
*
*     THE DATA IN *FLD* IS CONVERTED AS SPECIFIED IN *CONVTYP*.
*     THEN THE NUMBER (*SIZE*) OF RIGHT-JUSTIFIED CONVERTED
*     CHARACTERS IS LEFT-JUSTIFIED INTO THE RESULT FIELD *VLNTC*.
*
*     FUNC VLNTC(FLD,CONVTYP,SIZE)
*
*     ENTRY     (FLD)     - DATA FIELD TO CONVERT (RIGHT JUSTIFIED).
*               (CONVTYP) - "XCDD" FOR DECIMAL DISPLAY CONVERSION.
*                           "XCOD" FOR OCTAL DISPLAY CONVERSION.
*                           ANYTHING ELSE IMPLIES NO CONVERSION.
*               (SIZE)    - NUMBER OF CHARACTERS IN CONVERTED RESULT
*                           TO RETURN.
*
*     EXIT      (VLNTC) - CONVERTED DATA, LEFT JUSTIFIED, BLANK
*                         FILLED.
*
#
 
      ITEM FLD        I;             # FIELD TO CONVERT #
      ITEM CONVTYP    C(10);         # TYPE OF CONVERSION #
      ITEM SIZE       I;             # SIZE OF RESULT #
 
#
****  FUNC VLNTC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC VLBFILL;                # BLANK FILL #
        FUNC XCDD;                   # CONVERT INTEGER TO DECIMAL
                                       DISPLAY #
        FUNC XCOD;                   # CONVERT INTEGER TO OCTAL
                                       DISPLAY #
        END
 
#
****  FUNC VLNTC - XREF LIST END.
#
 
      ITEM NUMBER     I;             # TEMPORARY VARIABLE #
 
                                               CONTROL EJECT;
 
 
      NUMBER = FLD;
 
#
*     CONVERT FIELD AS SPECIFIED.
#
 
      IF CONVTYP EQ "XCDD"           # INTEGER TO DECIMAL #
      THEN
        BEGIN
        NUMBER = XCDD(FLD);
        END
 
      IF CONVTYP EQ "XCOD"           # INTEGER TO OCTAL #
      THEN
        BEGIN
        NUMBER = XCOD(FLD);
        END
 
#
*     BLANK FILL.
#
 
      VLBFILL(NUMBER,1);
 
#
*     RETURN THE FIELD WITH THE NUMBER OF CHARACTERS SPECIFIED,
*     LEFT JUSTIFIED, BLANK FILLED.
#
 
      VLNTC = C<10-SIZE,SIZE>NUMBER;
 
      END  # VLNTC #
 
    TERM
PROC VLPFC;
 
# TITLE VLPFC - READ PFC.                                             #
 
      BEGIN  # VLPFC #
 
#
**    VLPFC - READ THE *PFC*.
*
*     *VLPFC* BUILDS THE *PFC* EXTRACT FILES FROM THE *PFC*
*     CATALOG ENTRIES FOR THE SELECTED SUBFAMILIES AND
*     SELECTED SM(S).
*
*     PROC VLPFC
*
*     ENTRY     (DEVMASK) - SELECTED SUBFAMILY(S) DEVICE MASK.
*               (PAR$CS)  - SELECTED *SM-S*.
*               (PAR$FM)  - FAMILY.
*               (PAR$SB)  - SELECTED SUBFAMILIES.
*               (RPTFADR) - REPORT FILE *FET* ADDRESS.
*
*     EXIT      THE *PFC* EXTRACT FILES ARE WRITTEN.
*
*               FOR ERRORS DETECTED -
*                1) (TOTALERRS) - TOTAL VALIDATION ERRORS INCREMENTED.
*                2)  ERROR DETAIL LINES WRITTEN TO THE REPORT FILE.
*
*     MESSAGES  * ERROR READING *PFC* *
*
*     NOTES     VALIDATION ERRORS DETECTED ARE -
*               . INVALID *SM* IN *ASA*.
*
#
 
#
****  PROC VLPFC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC RDPFC;                  # READ PERMANENT FILE CATALOG #
        PROC REWIND;                 # INTERFACE TO *REWIND* MACRO #
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC VLMSG;                  # ISSUE INFORMATIONAL MESSAGE #
        FUNC VLNTC C(10);            # NUMERIC TO CHARACTER
                                       CONVERSION #
        PROC WRITEF;                 # INTERFACE TO *WRITEF* MACRO #
        PROC WRITEW;                 # INTERFACE TO *WRITEW* MACRO #
        PROC ZSETFET;                # INITIALIZES A *FET* FOR *I/O* #
        END
 
#
****  PROC VLPFC - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN COMMON DECK LISTING OFF #
*CALL COMBFAS
*CALL COMSPFM
*CALL COMTCTW
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLX
 
      ITEM VPEO       I;             # *PFC* ENTRY ORDINAL #
      ITEM I          I;             # TEMPORARY VARIABLE #
      ITEM IWC        I;             # INCREMENTED WORD COUNT #
      ITEM K          I;             # TEMPORARY VARIABLE #
      ITEM WDCNT      I;             # WORD COUNT #
 
#
*     BUFFER AREA FOR *PFC* ENTRY.
#
 
      ARRAY VPFCBUFFER [0:O"101"] S(1);  # *PFC* BUFFER #
      ITEM VPFC$WD    U(00,00,60);
 
#
*     ERROR LINES FOR REPORT FILE.
#
 
      ARRAY BADSM [0:0] S(5);       # INVALID *SM* REPORT LINE #
        BEGIN
        ITEM BAD$DESC   C(00,00,50) = ["***PF = XXXXXXX "];
        ITEM BAD$PFN    C(00,48,07);
        ITEM BAD$ERR    C(02,00,20) = ["INVALID SM IN PFC "];
        END
 
      ARRAY BADSM2 [0:0] S(5);      # INVALID *SM* REPORT LINE 2 #
        BEGIN
        ITEM BAD$DESC2  C(00,00,50) = ["   UI = NNNNNN "];
        ITEM BAD$UI     C(00,48,06);
        END
 
                                               CONTROL EJECT;
 
#
*     INITIALIZE FETS.
#
 
      SLOWFOR I = 0 STEP 1 UNTIL MAXSF
      DO                             # *PFC* EXTRACT FILES #
        BEGIN
        PEXTFADR = LOC(PFCE$FET[I]);
        PEXTBADR = LOC(PFCE$BUF[I]);
        PFCE$LFN[0] = EXTLFN;        # *LFN* OF *PFC* EXTRACT FILES #
        PFCE$LFNX[0] = I + "0";      # APPEND SUBFAMILY TO *LFN* #
        ZSETFET(PEXTFADR,PFCENAME,PEXTBADR,LPFCEBUF,SFETL);
        LOFPROC(PFCENAME);           # ADD LFN TO LIST OF FILES #
        REWIND(PFCEXTN[I],RCL);
        END
 
      LOFPROC("CATS");               # ADD LFN TO LIST OF FILES #
 
#
*     READ THE *PFC* FOR THE SELECTED SUBFAMILIES (DEVMASK).
#
 
      STAT = 0;
      SLOWFOR I = 0 STEP 1 WHILE STAT EQ 0
      DO
        BEGIN  # READ *PFC* ENTRIES #
 
        RDPFC(PAR$FM,DEVMASK,VPFCBUFFER,WDCNT,STAT);
 
#
*     EXIT IF NO SECTOR WAS RETURNED.
#
 
        IF STAT NQ 0
        THEN
          BEGIN
          TEST I;
          END
 
#
*     ELSE, PROCESS THE *PFC* SECTOR THAT WAS RETURNED.
#
 
        P<CNTRWORD> = LOC(VPFCBUFFER) + WDCNT;  # RETURN CONTROL WORD #
        VPEO = -1;                   # INITIALIZE *PFC* ENTRY ORDINAL #
 
        SLOWFOR IWC = 0 STEP PFCENTL WHILE (IWC LS WDCNT)
        DO
          BEGIN  # *PFC* SELECTION #
          VPEO = VPEO + 1;
          P<PFC> = LOC(VPFC$WD[IWC]);  # SET POINTER TO A *PFC* ENTRY #
 
#
*     SKIP THE *PFC* ENTRY IF IT IS NOT ACTIVE.
#
 
          IF PFC$UI[0] EQ 0
          THEN
            BEGIN
            TEST IWC;                # *PFC* ENTRY IS NOT ACTIVE #
            END
 
#
*     PERMANENT FILE DOES EXIST.
#
 
          SBINDX = PFC$SF[0];        # SUBFAMILY INDEX #
          P<ASA> = LOC(PFC$AA);      # ASA DEFINITIONS #
          SMINDX = ASASM[0];       # EXTRACT *SM* INDEX #
 
 
#
*     IF NOT *MAS* *PFC*.
#
 
          IF PFC$AT NQ ATAS
          THEN
            BEGIN
            TEST IWC;
            END
 
 
#
*     FOR INVALID *SM*, ISSUE DIAGNOSTIC.
#
 
          IF (PFC$AA[0] NQ 0) AND ((SMINDX EQ 0) OR (SMINDX GR "H"))
            THEN
            BEGIN
            TOTALERRS = TOTALERRS + 1;
            RPLINE(RPTFADR," ",0,1,EOPL);  # BLANK LINE #
            BAD$PFN[0] = VLNTC(PFC$FN[0]," ",10);  # *PFN* IN ERROR #
            RPLINE(RPTFADR,BADSM,4,50,EOPL);  # ISSUE ERROR LINE #
            BAD$UI[0] = VLNTC(PFC$UI[0],"XCOD",6);  # SET UI IN ERROR
                                                      LINE #
            RPLINE(RPTFADR,BADSM2,4,50,EOPL);  # ISSUE ERROR LINE #
            TEST IWC;
            END
 
#
*     SKIP *PFC* ENTRIES THAT DO NOT MATCH THE SELECTED SUBFAMILY
*     OR *SM*.
#
 
          IF (B<SBINDX,1>PAR$SB EQ 0 )  ##
            OR (B<SMINDX,1>PAR$SM EQ 0)  ##
            OR (PFC$AT[0] NQ ATAS)
          THEN
            BEGIN
            TEST IWC;
            END
 
#
*     BUILD THE EXTRACT RECORD.
#
 
          EXTR$PEO[0] = VPEO;        # *PFC* ENTRY ORDINAL #
          EXTR$DN[0] = CNTR$DN[0];   # DEVICE NUMBER #
          EXTR$TRK[0] = CNTR$TRK[0];  # TRACK #
          EXTR$SEC[0] = CNTR$SEC[0];  # SECTOR #
          EXTR$DA[0] = PFC$DA[0];
          EXTR$FLG[0] = PFC$AF[0];   # *ASA* FLAGS #
          EXTR$D[0] = 0;             # INITIALIZE DISK IMAGE FLAG #
          IF PFC$BT[0] NQ 0
          THEN                       # *PFC* TRACK IS NOT ZERO #
            BEGIN
            EXTR$D[0] = 1;           # DISK IMAGE EXISTS #
            END
 
          EXTR$ASA[0] = PFC$AA[0];   # SET THE *ASA* #
          EXTR$AT[0] = PFC$AT[0];
          EXTR$FCT[0] = EXTR$GP[0]*16 + EXTR$GPT[0];
          EXTR$PFN[0] = PFC$FN[0];   # SET THE *PFN* #
          EXTR$UI[0] = PFC$UI[0];    # SET THE *UI* #
          EXTR$BKDT[0] = PFC$UD[0];  # SET THE BACKUP DATE/TIME #
          EXTR$CREA[0] = PFC$CD[0];  # CREATION DATE/TIME #
 
#
*     SET THE BACKUP DATE/TIME TO BE THE LATEST DATE/TIME FROM
*     THE UTILITY CONTROL AND CONTROL MODIFICATION DATE/TIME
*     FIELDS.
#
 
          IF PFC$UD[0] LS PFC$KD[0]
          THEN                       # CONTROL IS NEWER THAN UTILITY #
            BEGIN
            EXTR$BKDT[0] = PFC$KD[0];  # BACKUP DATE/TIME #
            END
 
          WRITEW(PFCEXTN[SBINDX],EXTRECORD,RLEXTR,K);
          END  # *PFC* SELECTION #
 
        END  # READ *PFC* ENTRIES #
 
#
*    IF ERROR READING PFC, ISSUE MESSAGE AND ABORT.
#
 
      IF STAT NQ 1                   # IF NOT *EOI* #
      THEN                           # ERROR TYPE 2, 3, OR 4 #
        BEGIN
        VLERROR(VE"PFCERR",ABRT);    # ISSUE MESSAGE AND ABORT #
        END
 
#
*     WRITE EOFS ON ALL FILES.
#
 
      SLOWFOR I = 0 STEP 1 UNTIL MAXSF
      DO
        BEGIN
        WRITEF(PFCEXTN[I],RCL);
        REWIND(PFCEXTN[I],RCL);
        END
 
#
*     SET BITS TO INDICATE ALL SFM CATALOG FILES DO EXIST AND ARE
*     TO BE VALIDATED.
#
 
      B<0,8>SFMCATDEF = O"777";      # TURN THE 8 SUBCATALOG FLAGS ON #
 
      END  # VLPFC #
 
    TERM
PROC VLPFILL(FLD,(PARAM));
# TITLE VLPFILL - FILL PARAMETER IN MESSAGE TEXT.                     #
 
      BEGIN  # VLPFILL #
 
#
**    VLPFILL - FILL PARAMETER INTO MESSAGE TEXT.
*
*     *VLPFILL* LOCATES THE PARAMETER PLACE-HOLDER IN THE
*     TEXT AND REPLACES IT WITH THE PARAMETER CHARACTERS
*     IN THE *PARAM* WORD.
*
*     A MAXIMUM OF 40 CHARACTERS IS SCANNED.
*
*     PROC VLPFILL(FLD,PARAM)
*
*     ENTRY     (FLD)   - TEXT TO SCAN.
*               (PARAM) - PARAMETER TO PLACE IN TEXT.
*
*     EXIT      (FLD) - TEXT WITH THE PARAMETER FROM *PARAM* INSERTED.
*
#
 
 
      ITEM FLD        I;             # TEXT TO SCAN #
      ITEM PARAM      C(10);         # PARAMETER TO INSERT #
 
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
 
 
 
      ITEM PCHAR      I;             # PARAMETER CHARACTER INDEX #
      ITEM QCHAR      I;             # Q CHARACTER INDEX #
      ITEM Q          I;             # Q CHARACTER TEMPORARY #
 
      BASED
      ARRAY SCAN [0:0] S(4);         # TO SCAN TEXT FIELD #
      ITEM SCAN$WD    C(00,00,40);
                                               CONTROL EJECT;
 
      P<SCAN> = LOC(FLD);
 
 
      Q = 0;
      QCHAR = -1;                    # INITIALIZE #
 
#
*     SCAN THE TEXT LOOKING FOR A PARAMETER PLACE-HOLDER.
#
 
      REPEAT WHILE QCHAR LQ 40 AND Q NQ "Q"
      DO
        BEGIN  # PLACE-HOLDER SEARCH #
        QCHAR = QCHAR + 1;
        Q = C<QCHAR,1>SCAN$WD[0];    # GET A CHARACTER #
        END  # PLACE-HOLDER SEARCH #
 
#
*     MOVE PARAMETER INTO THE PLACE-HOLDER IF THERE WAS ONE.
#
 
      SLOWFOR PCHAR = 0 STEP 1 WHILE Q EQ "Q"
      DO
        BEGIN  # PLACE-HOLDER INSERT #
        C<QCHAR,1>SCAN$WD[0] = C<PCHAR,1>PARAM;  # REPLACE Q
                                                   CHARACTER #
        QCHAR = QCHAR + 1;
        Q = C<QCHAR,1>SCAN$WD[0];    # GET NEXT CHARACTER #
        END  # PLACE-HOLDER INSERT #
 
      RETURN;
      END  # VLPFILL #
 
    TERM
PROC VLPRSET;
# TITLE VLPRSET - PRESET PARAMETERS AND FILES.                        #
 
      BEGIN  # VLPRSET #
 
#
**    VLPRSET - PRESET PARAMETERS AND FILES.
*
*     *VLPRSET* INITIALIZES ALL PARAMETERS AND PERFORMS
*     ALL PRESET FUNCTIONS.  THIS INCLUDES -
*      . GET DEFAULT FAMILY AND SUBSYSTEM ID.
*      . CRACK CONTROL CARD AND EDIT PARAMETERS.
*      . LIST THE CONTROL CARD PARAMETERS IN THE REPORT FILE.
*      . OPEN/INITIALIZE FILES.
*
*     PROC VLPRSET
*
*     ENTRY     THE CONTROL CARD IN *RA* + 70B.
*
*     EXIT      (DEF$FAM)         - DEFAULT FAMILY.
*               (DEVMASK)         - DEVICE MASK FOR SELECTED
*                                   SUBFAMILIES.
*               (PAR$XX)          - PARAMETER VALUES WHERE XX =
*                                   KEYWORD.
*               (RPTFILE)         - ADDRESS OF REPORT FILE *FET*.
*               (SSID$VL)         - SUBSYTEM IDENTIFICATION.
*               (ARRAY FIXITFILE) - FIXIT FILE *FET*.
*               (ARRAY PROBFILE)  - PROBLEM FILE *FET*.
*
*     MESSAGES  * INVALID SM PARAMETER.*
*               * INVALID FX PARAMETER.*
*               * ILLEGAL - L AND RF PARAMETERS.*
*               * ILLEGAL - RF AND AM PARAMETERS.*
*               * ILLEGAL - RF AND FM PARAMETERS.*
*               * ILLEGAL - RL AND NO RF PARAMETERS.*
*               * INVALID - SB PARAMETER.*
*               * INVALID - ST PARAMETER.*
*               * CONTROL CARD SYNTAX ERROR.*
*               * ABORT RUN DUE TO ERRORS.*
*
#
 
 
#
****  PROC VLPRSET - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC BZFILL;                   # BLANK OR ZERO FILL #
        PROC GETFAM;                 # SET FAMILY TABLE #
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC PFD;                      # PERMANENT FILE ACCESS #
        PROC SETPFP;                   # SET FILE PARAMETERS#
        PROC RETERN;                 # RETURNS SPECIFIED FILE #
        PROC REWIND;                 # INTERFACE TO *REWIND* MACRO #
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC RPOPEN;                 # OPENS A PRINT FILE #
        PROC VLBFILL;                # BLANK FILL #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        FUNC VLNTC C(10);            # NUMERIC TO CHARACTER
                                       CONVERSION #
        PROC VLPFC;                  # READ *PFC* #
        PROC VLRDF;                  # READ RDF FILE #
        PROC VLTAB;
        PROC VLTITLE;                # ISSUE REPORT TITLE #
        PROC XARG;                   # CRACK PARAMETER LIST #
        FUNC XDXB;                   # CONVERT DISPLAY CODE TO BINARY #
        PROC ZSETFET;                # INITIALIZES A *FET* FOR *I/O* #
        END
 
#
****  PROC VLPRSET - XREF LIST END.
#
 
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTINGS #
 
*CALL COMBFAS
*CALL COMBBZF
*CALL COMBPFP
*CALL COMSPFM
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLP
*CALL COMTVLX
 
 
      ITEM ARGADDR    I;             # ARGUMENT TABLE ADDRESS #
      ITEM ARGERR     I;             # CTL CARD ARGUMENT ERROR #
      ITEM CHAR       I;             # SCRATCH FIELD #
      ITEM I          I;             # TEMPORARY VARIABLE #
      ITEM J          I;             # TEMPORARY VARIABLE #
      ITEM K          I;             # TEMPORARY VARIABLE #
      ITEM PAR        I;             # SCRATCH FIELD #
 
 
      BASED
      ARRAY ARGELEMENT [0:0] S(1);   # TO EXTRACT THE ARGUMENTS #
        BEGIN
        ITEM ARGITEM    U(00,00,60);
        ITEM ARGITEMC   C(00,00,10);
        ITEM ARGSCAN    C(00,00,20);  # FOR A 2 WORD PARAMETER #
        END
 
 
      ARRAY PARIDS [0:VARGL] S(1);   # PARAMETER IDS FOR REPORT #
        BEGIN
        ITEM PARNME     C(00,30,5);
        ITEM PARNME1    C(VLF,30,5) = [ "L  = " ];
        ITEM PARNME2    C(VRF,30,5) = [ "RF = " ];
        ITEM PARNME3    C(VAM,30,5) = [ "AM = " ];
        ITEM PARNME4    C(VSM,30,5) = [ "SM = " ];
        ITEM PARNME6    C(VFM,30,5) = [ "FM = " ];
        ITEM PARNME7    C(VFX,30,5) = [ "FX = " ];
        ITEM PARNME8    C(VRL,30,5) = [ "RL = " ];
        ITEM PARNME9    C(VSB,30,5) = [ "SB = " ];
        ITEM PARNME10   C(VST,30,5) = [ "ST = " ];
        END
 
#
*     TO BUILD THE PARAMETER FOR THE REPORT FILE.
#
 
      ARRAY PARVALUE [0:0] S(2);     # PARAMETER DISPLAY CD VALUE #
        BEGIN
        ITEM PAR$VALUE  C(00,00,20);  # PARAMETER #
        ITEM PAR$VALEND U(00,42,18);  # END OF FIRST PARAMETER #
        ITEM PAR$VAL2   C(01,00,10);  # SECOND WORD OF PARAMETER #
        END
                                               CONTROL EJECT;
 
#
*     GET THE SYSTEM DEFAULT FAMILY AND THE SUBSYSTEM IDENTIFICATION.
#
 
      SSID$VL = ATAS;
      GETFAM(FAMT,I,J,K,SSID$VL);
      DEF$FAM = FAM$NAME[K];
 
#
*     CRACK THE CONTROL CARD.
#
 
      VLTAB(ARGADDR);                # GET ADDR OF ARGUMENT TABLE #
      XARG(ARGADDR,0,ARGERR);        # CRACK PARAMETERS BASED ON
                                       TABLE #
 
      IF ARGERR NQ 0
      THEN                           # SYNTAX ERROR #
        BEGIN
        VLERROR(VE"SYNTAX",ABRT);    # ABORT WITH MESSAGE #
        END
 
      P<ARGELEMENT> = LOC(VARGUMENTS);
 
#
*     MOVE CONTROL CARD ARGUMENTS TO PARAMETERS.  PARAMETERS ARE
*     STORED IN PAR$XX (WHERE XX IS THE KEYWORD) FOR SUBSEQUENT
*     PROGRAM ACCESS.
#
 
      PAR$LF = VARG$LF[0];           # *L* PARAMETER VALUE #
      PAR$RF = VARG$RF[0];           # *RF* PARAMETER VALUE #
      PAR$AM = VARG$AM[0];           # *AM* PARAMETER VALUE #
 
      SLOWFOR I = 0 STEP 1 UNTIL 7
      DO                             # *SM* PARAMETER #
        BEGIN  # MOVE ARGUMENTS #
        CHAR = C<I,1>ARGSCAN[VSM];  # A *SM* CHARACTER #
      IF CHAR EQ 0
        THEN                         # END OF *CS* PARAMETER #
          BEGIN
          TEST I;
          END
 
        IF CHAR GR "H"
        THEN                         # ILLEGAL CHARACTER #
          BEGIN
          VLERROR(VE"SMPAR",NOABT); # ISSUE MESSAGE #
          END
 
        ELSE
          BEGIN  # SET *SM* BIT #
          IF B<CHAR,1>PAR$SM EQ 1
          THEN
            BEGIN
            VLERROR(VE"DUPCS",NOABT);
            END
 
          ELSE
            BEGIN
            B<CHAR,1>PAR$SM = 1;
            END
 
          END  # SET *CS* BIT #
 
 
        END  # MOVE ARGUMENTS #
 
      PAR$FM = VARG$FM[0];           # FM PARAMETER VALUE #
 
      STAT = XDXB(VARG$FX[0],"D",PAR$FX);  # CONVERT FX VALUE #
      IF STAT NQ 0
      THEN                           # ILLEGAL FX VALUE #
        BEGIN
        VLERROR(VE"FXPAR",NOABT);    # ISSUE MESSAGE #
        END
 
      PAR$RL = VARG$RL[0];           # RL PARAMETER VALUE #
 
      SLOWFOR J = 0 STEP 1 UNTIL 9
      DO                             # SB PARAMETER #
        BEGIN  # SUBFAMILY ARGUMENTS #
        CHAR = C<J,1>ARGITEM[VSB];   # EXTRACT A SUBFAMILY NUMBER #
        IF CHAR EQ 0
        THEN                         # END OF SB VALUE #
          BEGIN
          TEST J;
          END
 
        IF CHAR LS "0" OR CHAR GR "7"
        THEN                         # ILLEGAL SUBFAMILY #
          BEGIN
          VLERROR(VE"SBPAR",NOABT);  # ISSUE MESSAGE #
          END
 
        ELSE
          BEGIN  # SET SUBFAMILY BIT #
          IF B<CHAR-"0",1>PAR$SB EQ 1
          THEN
            BEGIN
            VLERROR(VE"DUPSB",NOABT);
            END
 
          ELSE
            BEGIN
            B<CHAR-"0",1>PAR$SB = 1;  # SET *SB* BIT #
            B<59-(CHAR-"0"),1>DEVMASK = 1;  # RIGHT JUSTIFIED MASK #
            END
 
          END  # SET SUBFAMILY BIT #
 
        END  # SUBFAMILY ARGUMENTS #
 
      IF VARG$ST[0] EQ O"30555555555555555555"
      THEN                    # DEFAULT *ST* #
        BEGIN
        VARG$ST[0] = O"34555555555555555555";
        END
 
      STAT = XDXB(VARG$ST[0],"D",PAR$ST);  # CONVERT ST PARAMETER #
      IF STAT NQ 0
      THEN                           # ILLEGAL ST VALUE #
        BEGIN
        VLERROR(VE"STPAR",NOABT);    # ISSUE MESSAGE #
        END
 
#
*     VERIFY THAT THE PARAMETER COMBINATIONS ARE LEGAL.
*     ERRORS ARE -
*     . *RF* AND *AM* PARAMETER TOGETHER,
*     . *RF* AND *FM* PARAMETER TOGETHER,
*     . *RL* AND NO *RF* PARAMETER.
#
 
#
*     L PARAMETER = RF PARAMETER.
#
 
      IF (PAR$LF NQ 0) AND (PAR$LF EQ PAR$RF)
      THEN
        BEGIN
        VLERROR(VE"LFRF",NOABT);     # ISSUE MESSAGE #
        END
 
#
*     RL PARAMETER BUT NO RF.
#
 
      IF (PAR$RL NQ 0) AND (PAR$RF EQ 0)
      THEN
        BEGIN
        VLERROR(VE"RLNRF",NOABT);    # ISSUE MESSAGE #
        END
 
#
*     RF AND FM SPECIFIED.
#
 
      IF (PAR$RF NQ 0) AND (PAR$FM NQ 0)
      THEN
        BEGIN
        VLERROR(VE"RFFM",NOABT);     # ISSUE MESSAGE #
        END
 
#
*     RF AND AM SPECIFIED.
#
 
      IF (PAR$RF NQ 0) AND (PAR$AM NQ 0)
      THEN
        BEGIN
        VLERROR(VE"RFAM",NOABT);     # ISSUE MESSAGE #
        END
 
#
*     IF ANY CONTROL CARD ERRORS, ABORT.
*     (ERRORS ARE COUNTED IN VLERROR).
#
 
      IF CNTPROGERR NQ 0
      THEN                           # SOME ERRORS OCCURRED #
        BEGIN
        VLERROR(VE"ABORT",ABRT);     # ABORT WITH MESSAGE #
        END
 
 
#
*     SET THE FAMILY PARAMETER TO THE DEFAULT FAMILY IF THE
*     FM OPTION IS ACTIVE (NO RF PARAMETER) BUT THE FAMILY WAS
*     NOT SPECIFIED.
#
 
      IF (PAR$RF EQ 0) AND ((VARG$IFM[0] EQ -1) OR (PAR$FM EQ 0))
        THEN
        BEGIN
        PAR$FM = DEF$FAM;
        VARG$FM[0] = PAR$FM;
        END
 
#
*     OPEN REPORT FILE.
#
 
      IF PAR$LF NQ 0
      THEN                           # L PARAMETER ACTIVE #
        BEGIN
        RPTFADR = LOC(RPTFILE);      # REPORT FILE FET ADDRESS #
        END
 
      RPOPEN(PAR$LF,RPTFADR,VLTITLE);
 
#
*     ISSUE REPORT OF SPECIFIED AND DEFAULTED PARAMETERS.
#
 
#
*     PRINT THE CONTROL CARD AS IT IS IN THE RA(70) AREA.
#
 
      P<RACOM> = 0;
 
      VLBFILL(RACOM[CCADDR],8);      # BLANK FILL #
      RPLINE(RPTFADR," ",0,1,EOPL);  # A BLANK LINE #
      RPLINE(RPTFADR,RACOM[CCADDR],12,80,EOPL);  # CONTROL CARD #
      RPLINE(RPTFADR," ",0,1,EOPL);  # A BLANK LINE #
 
#
*     LIST ALL PARAMETERS AND THEIR VALUES.
#
 
      SLOWFOR PAR = 0 STEP 1 UNTIL VARGL - 1
      DO
        BEGIN  # PARAMETER LISTING #
        IF PAR EQ VSM+1              # 2ND WORD OF *SM* PARAMETER #
        THEN
          BEGIN
          TEST PAR;
          END
 
        RPLINE(RPTFADR,PARNME[PAR],25,5,COPL);  # KEYWORD #
        IF ARGITEM[PAR] EQ -1
        THEN
          BEGIN
          ARGITEMC[PAR] = "Y";
          END
 
        IF ARGITEM[PAR] EQ 0
        THEN                         # PARAMETER NOT SPECIFIED #
          BEGIN
          ARGITEMC[PAR] = "0";       # USE A CODED ZERO #
          END
 
        PAR$VALUE = ARGITEMC[PAR];   # GET PARAMETER VALUE #
        IF PAR EQ VSM
        THEN                         # INDEX AT CS PARAMETER #
          BEGIN
          PAR$VAL2[0] = ARGITEMC[PAR+1];  # GET 2ND WORD #
          END
 
        IF PAR EQ VFM
        THEN
          BEGIN
          PAR$VALEND[0] = 0;
          END
 
        VLBFILL(PARVALUE,2);
        RPLINE(RPTFADR,PARVALUE[0],30,20,EOPL);  # PARAMETER VALUE #
 
        END  # PARAMETER LISTING #
 
      RPLINE(RPTFADR,"0",0,1,EOPL);  # 2 BLANK LINES #
 
 
#
*     BUILD *PFC* EXTRACT FILES FROM THE *PFC* IF NO RF PARAMETER
*     WAS SPECIFIED.
#
 
      IF PAR$RF EQ 0
      THEN
        BEGIN
        VLPFC;
        END
 
#
*     BUILD *PFC* EXTRACT FILES FROM THE RDF FILE IF THE RF PARAMETER
*     WAS SPECIFIED.
#
 
      ELSE
        BEGIN
        VLRDF;
        END
 
#
*     INITIALIZE INTERNAL FILES.
#
 
      PROBFADR = LOC(PROBFILE);      # PROBLEM FILE #
      PROBBADR = LOC(PROBBUF);
      ZSETFET(PROBFADR,PROBLFN,PROBBADR,LPROBBUF,SFETL);
      RETERN(PROBFILE[0],RCL);
      LOFPROC(PROBLFN);              # ADD LFN TO LIST OF FILES #
 
      FIXFADR = LOC(FIXITFILE);      # FIXIT FILE #
      FIXBADR = LOC(FIXITBUF);
      ZSETFET(FIXFADR,FIXLFN,FIXBADR,LFIXBUF,SFETL);
      RETERN(FIXITFILE[0],RCL);
      LOFPROC(FIXLFN);               # ADD LFN TO LIST OF FILES #
      REWIND(FIXITFILE,RCL);
 
 
#
*     INITIALIZE RELEASE FILE.
#
 
      PFP$FAM[0] = PAR$FM;
      PFP$UI[0] = DEF$UI;
      PFP$FG1[0] = TRUE;
      PFP$FG4[0] = TRUE;
      SETPFP(PFP);
      IF PFP$STAT[0] NQ 0
      THEN
        BEGIN
        VLERROR(VE"NOFAM",ABRT);
        END
 
      IF (PAR$RF NQ 0) AND (PAR$RL NQ 0)
      THEN                            # SET UP *RELCOM* FILE #
        BEGIN
        RELNAME = RELLFN;             # ATTACH COMMUNICATION FILE #
        BZFILL(RELNAME,TYPFILL"ZFILL",7);
        PFD("ATTACH",RELNAME,0,"M","W","RC",STAT,"NA",0,0);
        IF STAT NQ OK
        THEN                          # PROCESS ATTACH ERROR FLAG #
          BEGIN
          IF STAT EQ FBS
          THEN                        # COMMUNICATION FILE BUSY #
            BEGIN
            VLERROR(VE"ABORT",ABRT);
            END
 
          IF STAT EQ FNF
          THEN                        # FILE DOES NOT EXIST #
            BEGIN
            PFD("DEFINE",RELNAME,0,"BR","N","RC",STAT,0);
            IF STAT NQ OK
            THEN                      # DEFINE ERROR #
              BEGIN
              VLERROR(VE"ABORT",ABRT);
              END
 
            END
 
           ELSE                        # ERROR OTHER THAN FBS OR FNF #
             BEGIN
             VLERROR(VE"ABORT",ABRT);
             END
 
           END                         # PROCESS ATTACH ERROR #
 
         RELFADR = LOC(RELCFILE);
         RELBADR = LOC(RELCBUF);
         ZSETFET(RELFADR,RELNAME,RELBADR,LFIXBUF);
         LOFPROC(RELNAME);              # ADD LFN TO LIST OF FILES #
         REWIND(RELCFILE[0],RCL);
         END                           # SET UP *RELCOM* FILE #
 
      END  # VLPRSET #
 
    TERM
PROC VLRCL(COUNT);
# TITLE VLRCL - RECALL.                                               #
 
      BEGIN  # VLRCL #
 
#
**    VLRCL - RECALL.
*
*     *VLRCL* ISSUES RECALLS TO THE SYSTEM UNTIL THE *COUNT*
*     EXPIRES.
*
*     PROC VLRCL(COUNT)
*
*     ENTRY     (COUNT) - NUMBER OF TIMES TO ISSUE THE PERIODIC RECALL.
*
#
 
      ITEM COUNT      I;             # RECALL LOOP CONTROL #
 
#
****  PROC VLRCL - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC RECALL;                 # INTERFACE TO *RECALL* MACRO #
        END
 
#
****  PROC VLRCL - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
 
      ITEM II         I;             # TEMPORARY LOOP VARIABLE #
 
                                               CONTROL EJECT;
 
      SLOWFOR II = 0 STEP 1 UNTIL COUNT
      DO
        BEGIN
        RECALL(0);
        END
 
      RETURN;
      END  # VLRCL #
 
    TERM
PROC VLRDF;
 
# TITLE VLRDF - READ RDF FILE.                                        #
 
      BEGIN  # VLRDF #
 
#
**    VLRDF - READ THE *RDF* FILE.
*
*     *VLRDF* BUILDS THE *PFC* EXTRACT FILES AND THE SFM CATALOG
*     FILES FROM THE *RDF* FILE SELECTED BY THE *RF* CONTROL CARD
*     PARAMETER.  THIS ROUTINE CONTROLS THE READING OF THE *RDF*
*     FILE.  IT CALLS *VLRDF2* TO PROCESS THE DATA.
*
*     PROC VLRDF
*
*     ENTRY     (PAR$CS)  - SELECTED *SM-S*.
*               (PAR$RF)  - LFN OF THE *RDF* FILE.
*               (PAR$SB)  - SELECTED SUBFAMILIES.
*               (RPTFADR) - ADDRESS OF THE REPORT FILE *FET*.
*
*     EXIT      THE SFM CATALOG FILES ARE BUILT AS LOCAL FILES.
*
*               THE *PFC* EXTRACT FILES ARE BUILT AS LOCAL FILES.
*
*               IF A VALIDATION ERROR IS DETECTED IN THE *PFC* DATA -
*                1) (TOTALERRS) IS INCREMENTED.
*                2) DETAIL LINES DESCRIBING THE ERROR ARE WRITTEN TO
*                   THE REPORT FILE.
*
*     MESSAGES  * SSVAL ABNORMAL, VLRDF.*
*               * *RDF* FILE ERROR - MISSING HEADER.*
*               * *RDF* FILE ERROR - BAD RECORD LENGTH.*
*
*     NOTES     THE STRUCTURE OF THE *RDF* FILE IS -
*                 DATA RECORDS - CONSIST OF A ONE WORD CONTROL WORD
*                                AND DATA WORDS.
*                 CONTROL WORD - SPECIFIES THE LENGTH AND TYPE OF THE
*                                FOLLOWING DATA.
*                 DATA TYPES -   HEADER RECORD.
*                                *PFC* EXTRACT RECORD.
*                                SFM CATALOG RECORD(S).
*                 DATA LENGTH -  LENGTH OF THE DATA IN WORDS.  IF THE
*                                LENGTH IS ZERO, THE DATA RECORD IS
*                                TERMINATED BY A LOGICAL-END-OF-RECORD.
*                 *EOR* -        (LOGICAL-END-OF-RECORD) MAY BE USED
*                                BETWEEN DATA RECORDS AT LOGICAL
*                                BREAKS AND SHOULD BE EXPECTED
*                                ANYWHERE.
*
*               A TYPICAL SEQUENCE IS -
*                 - HEADER RECORD FOLLOWED BY *EOR*.
*                 - *PFC* EXTRACT RECORDS FOR A DEVICE FOLLOWED BY
*                   *EOR*
*                 - .
*                 - .
*                 - .
*                 - SFM CATALOG RECORD (COPY OF THE PERMANENT FILE)
*                   FOR A SUBFAMILY FOLLOWED BY *EOR*.
*                 - .
*                 - .
*                 - .
*                 -EOI
*
*               IF THE *RDF* HEADER RECORD IS INVALID OR MISSING, THE
*               PROGRAM ABORTS WITH A DIAGNOSTIC MESSAGE.  AN INVALID
*               HEADER IS DETERMINED BY THE IDENTIFICATION THAT IS
*               PLACED IN THE HEADER BY *PFDUMP*.
*
*               ONLY THE *PFC* EXTRACT RECORDS FOR THE SELECTED
*               SUBFAMILIES AND SELECTED *SM-S* ARE WRITTEN TO THE
*               *PFC* EXTRACT FILE THE RECORDS ARE SELECTED BY
*               ANALYZING THE *ASA* FIELD.  THE *SM* IN THE *ASA* IS
*               INVALID, ERROR DETAIL LINES ARE FORMATTED AND ISSUED
*               TO THE REPORT FILE AND THE ERROR IS INCLUDED IN THE
*               TOTAL ERRORS COUNTER.
*
*               THE SFM CATALOGS ARE WRITTEN TO LOCAL FILES TO BE
*               ACCESSED LATER VIA THE CATALOG ACCESS ROUTINES.  A MASK
*               IS BUILT IDENTIFYING THOSE SUBFAMILIES THAT WERE
*               PRESENT ON THE *RDF* FILE.  ONLY THOSE SUBFAMILIES WILL
*               BE USED IN THE VALIDATION PROCESS.
#
 
 
 
#
****  PROC VLRDF - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        FUNC EDATE C(10);            # EDIT DATE FROM PACKED FORMAT #
        FUNC ETIME C(10);            # EDIT TIME FROM PACKED FORMAT #
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC READ;                   # INTERFACE TO *READ* MACRO #
        PROC READO;                  # INTERFACE TO *READO* MACRO #
        PROC READW;                  # INTERFACE TO *READW* MACRO #
        PROC REWIND;                 # INTERFACE TO *REWIND* MACRO #
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC WRITEF;                 # INTERFACE TO *WRITEF* MACRO #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC VLMSG;                  # ISSUE INFORMATIONAL MESSAGE #
        FUNC VLNTC C(10);            # NUMERIC TO CHARACTER
                                       CONVERSION #
        PROC VLRDF2;                 # PROCESS RDF FILE RECORDS #
        PROC WRITEW;                 # INTERFACE TO *WRITEW* MACRO #
        PROC ZSETFET;                # INITIALIZES A *FET* FOR *I/O* #
        END
 
#
****  PROC VLRDF - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTINGS #
 
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBMCT
*CALL COMBMAP
 
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLM
*CALL COMTVLP
*CALL COMTVLX
 
      ITEM DATA       I;             # LOGICAL RECORD SIZE #
      ITEM FATEOR     B;             # FILE AT EOR #
      ITEM I          I;             # TEMPORARY LOOP VARIABLE #
      ITEM J          I;             # TEMPORARY LOOP VARIABLE #
      ITEM L          I;             # TEMPORARY LOOP VARIABLE #
 
                                               CONTROL EJECT;
 
#
*     INITIALIZE THE FETS.
#
 
      SLOWFOR I = 0 STEP 1 UNTIL MAXSF
      DO                             # *PFC* EXTRACT FILES, 1 PER
                                       SUBFAMILY #
        BEGIN  # *FET* INITIALIZATION #
        PEXTFADR = LOC(PFCE$FET[I]);
        PEXTBADR = LOC(PFCE$BUF[I]);
        PFCE$LFN[0] = EXTLFN;        # *LFN* FOR *PFC* EXTRACT FILE #
        PFCE$LFNX[0] = I + "0";      # APPEND SUBFAMILY TO *LFN* #
        ZSETFET(PEXTFADR,PFCENAME,PEXTBADR,LPFCEBUF,SFETL);
        LOFPROC(PFCENAME);           # ADD LFN TO LIST OF FILES #
        REWIND(PFCEXTN[I],RCL);
        END  # *FET* INITIALIZATION #
 
      RDFFADR = LOC(RDFFILE);        # RDF FILE #
      RDFBADR = LOC(RDFBUF);
      ZSETFET(RDFFADR,PAR$RF,RDFBADR,LRDFBUF,SFETL);
 
      ZVALFADR = LOC(ZZZVALX);       # SFM CATALOG FILE #
      ZVALBADR = LOC(ZZZVBUF);
      ZSETFET(ZVALFADR,ZVALLFN,ZVALBADR,LZZZVBUF,SFETL);
      LOFPROC(ZVALLFN);              # ADD LFN TO LIST OF FILES #
 
      REWIND(RDFFILE,RCL);
 
#
*     PROCESS UNTIL EOI IS ENCOUNTERED ON THE RDF FILE.
#
 
      FATEOR = TRUE;                 # TO FORCE INITIAL READ #
      STAT = 0;
 
      REPEAT WHILE STAT NQ EOI
      DO
        BEGIN  # PROCESS RDF FILE #
        IF FATEOR
        THEN                         # FILE IS AT EOR CONDITION #
          BEGIN
          READ(RDFFILE,NRCL);        # START *CIO* READ #
          FATEOR = FALSE;
          END
 
#
*     READ ONE WORD TO GET THE CONTROL WORD.
#
 
        RDFC$CTYP[0] = 0;
        READO(RDFFILE,RDFCTLWORD,STAT);
 
#
*     IF CIO ERROR ON RDF, ABORT.
#
 
        IF STAT EQ CIOERR
        THEN
          BEGIN
          MP$WD[1] = "VLRDF";        # NAME FOR MESSGE #
          VLERROR(VE"SYSERR",ABRT);  # ABORT WITH MESSAGE #
          END
 
#
*     IF AT EOR, EOF, OR EOI, THEN NO DATA TO PROCESS.
#
 
        IF STAT NQ OK
        THEN
          BEGIN
          FATEOR = TRUE;             # INDICATE *CIO* HAS STOPPED #
          TEST DUMMY;                # EXIT, NO DATA #
          END
 
#
*     CHECK CONTENTS OF RDF CONTROL WORD COUNT FIELD.
#
 
        IF RDFC$WC[0] GR RDFMAXWC
        THEN                         # RDF DATA LENGTH ILLEGAL #
          BEGIN
          VLERROR(VE"RDFLEX",ABRT);  # ABORT WITH MESSAGE #
          END
 
#
*     CALCULATE LENGTH OF DATA FOLLOWING CONTROL WORD.
#
 
        DATA = RDFC$WC[0];           # LENGTH OF DATA RECORD #
        IF DATA EQ 0
        THEN                         # DATA ENDS AT EOR #
          BEGIN
          DATA = 77777777;           # SET SIZE TO VERY LARGE #
          END
 
#
*     SET THE LENGTH PARAMETER FOR READW TO BE THE MINIMUM OF
*     THE DATA SIZE OR THE RDF BUFFER SIZE.
#
 
        L = DATA;                    # SIZE OF DATA EXPECTED #
        IF L GR LRDFRB
        THEN
          BEGIN
          L = LRDFRB;                # SIZE OF RECORD BUFFER #
          END
 
#
*     READ THE DATA RECORD (MAY TAKE MORE THAN ONE READ
*     DEPENDING ON THE LENGTH).
#
 
        SLOWFOR J = 0 STEP 1 WHILE DATA GR 0
        DO
          BEGIN  # READING DATA RECORD #
          DATA = DATA - L;           # LENGTH REMAINING #
          READW(RDFFILE,RDFRECORD,L,STAT);  # GET RECORD #
 
#
*     IF CIO ERROR, ABORT.
#
 
          IF STAT EQ CIOERR
          THEN
            BEGIN
            MP$WD[1] = "VLRDF";
            VLERROR(VE"SYSERR",ABRT);  # ABORT WITH MESSAGE #
            END
 
#
*     IF A SHORT RECORD WAS DETECTED, THEN THE FILE IS AT EOR.
#
 
          IF STAT NQ OK
          THEN
            BEGIN
            FATEOR = TRUE;           # INDICATE AT EOR #
            DATA = 0;                # END OF RECORD CONDITION #
            L = STAT - LOC(RDFRECORD);  # LENGTH THAT WAS READ #
            END
 
#
*     PROCESS THE DATA IN THE RECORD BUFFER.
#
 
          VLRDF2(J,DATA,L);          # PROCESS THE DATA RECORD #
 
          END  # READING DATA RECORD #
 
        END  # PROCESS RDF FILE #
 
      IF NOT RDFHDROK
      THEN                           # INVALID RDF FILE HEADER #
        BEGIN
        VLERROR(VE"RDFHDR",ABRT);    # ABORT WITH MESSAGE #
        END
 
#
*     WRITE EOF"S ON *PFC* EXTRACT FILES AND REWIND.
#
 
      SLOWFOR I = 0 STEP 1 UNTIL MAXSF
      DO
        BEGIN
        WRITEF(PFCEXTN[I],RCL);
        REWIND(PFCEXTN[I],RCL);
        END
 
 
 
      END  # VLRDF #
 
    TERM
PROC VLRDF2(BFLG,EFLG,L);
 
# TITLE VLRDF2 - PROCESS RDF FILE RECORDS.                            #
 
      BEGIN  # VLRDF2 #
 
#
**    VLRDF2 - PROCESS THE *RDF* FILE RECORDS.
*
*     *VLRDF2* VERIFIES THE *RDF* DATA RECORD AND PROCESSES IT
*     ACCORDING TO ITS DATA TYPE.  *PFC* EXTRACT DATA RECORDS
*     ARE WRITTEN TO THE APPROPRIATE LOCAL *PFC* EXTRACT FILE.
*     SFM CATALOG DATA RECORDS ARE WRITTEN TO THEIR LOCAL
*     FILE.
*
*     PROC VLRDF2(BFLG,EFLG,L)
*
*     ENTRY     (BFLG)             - INDICATES BEGINNING OF DATA IF
*                                    ZERO.
*               (EFLG)             - INDICATES END OF DATA IF ZERO.
*               (L)                - LENGTH OF THE DATA IN THE BUFFER.
*               (PAR$CS)           - SELECTED *SM-S*.
*               (PAR$SB)           - SELECTED SUBFAMILIES.
*               (ARRAY RDFRECORD)  - BUFFER THAT CONTAINS THE DATA
*                                    READ.
*               (ARRAY RDFCTLWORD) - CONTAINS THE CONTROL WORD.
*
*     EXIT      (PAR$FM) - *RDF* FAMILY FROM THE *RDF* HEADER RECORD.
*               (RDFDT)  - PACKED DATE AND TIME OF THE *RDF* FILE.
*               *PFC* EXTRACT FILE(S) CREATED.
*               SFM CATALOG FILE(S) CREATED.
*
*               THE *RDF* FAMILY AND BACKUP DATE/TIME INFORMATIONAL
*               LINES ARE WRITTEN TO THE REPORT FILE.
*
*               IF AN INVALID *SM* WAS DETECTED IN THE *PFC* EXTRACT
*               RECORD,
*                . ERROR LINES WERE WRITTEN TO THE REPORT FILE.
*                . (TOTALERRS) - TOTAL VALIDATION ERRORS COUNTER
*                                INCREMENTED.
*
*     MESSAGES  * *RDF* FILE ERROR - UNIDENTIFIED DATA.*
*               * *RDF* FILE ERROR - MISSING HEADER.*
*
*
#
 
      ITEM BFLG       I;             # BEGINNING OF RECORD IF = 0 #
      ITEM EFLG       I;             # END OF RECORD IF = 0 #
      ITEM L          I;             # LENGTH OF DATA RECORD #
 
#
****  PROC VLRDF2 - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        FUNC EDATE C(10);            # EDIT DATE FROM PACKED FORMAT #
        FUNC ETIME C(10);            # EDIT TIME FROM PACKED FORMAT #
        PROC REWIND;                 # INTERFACE TO *REWIND* MACRO #
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC VLMSG;                  # ISSUE INFORMATIONAL MESSAGE #
        FUNC VLNTC C(10);            # NUMERIC TO CHARACTER
                                       CONVERSION #
        PROC WRITEF;                 # INTERFACE TO *WRITEF* MACRO #
        PROC WRITEW;                 # INTERFACE TO *WRITEW* MACRO #
        END
 
#
****  PROC VLRDF2 - XREF LIST END.
#
 
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBMCT
*CALL COMBMAP
*CALL COMSPFM
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLX
 
      ITEM KSTAT      I;             # TEMPORARY VARIABLE #
      ITEM PROCESSED  B;             # RECORD PROCESSED OK #
 
#
*     ERROR LINES FOR THE REPORT.
#
 
      ARRAY BADSM [0:0] S(5);       # INVALID *SM* REPORT LINE #
        BEGIN
        ITEM BAD$DESC   C(00,00,50) = ["***PF = XXXXXXX "];
        ITEM BAD$PFN    C(00,48,07);  # *PFN* OF *PFC* #
        ITEM BAD$ERR    C(02,00,20) = ["INVALID SM IN PFC "];
        END
 
      ARRAY BADSM2 [0:0] S(5);      # INVALID *SM* REPORT LINE 2 #
        BEGIN
        ITEM BAD$DESC2  C(00,00,50) = ["   UI = NNNNNN "];
        ITEM BAD$UI     C(00,48,06);  # UI OF *PFC* #
        END
 
                                               CONTROL EJECT;
 
 
      PROCESSED = FALSE;
 
#
*     HEADER RECORD PROCESSING OCCURS IF THE CONTROL WORD TYPE
*     INDICATES THAT IT IS A HEADER RECORD.  IF THE DATA IS FROM THE
*     FIRST READ OF THE RECORD, IMPORTANT DATA IS EXTRACTED FROM THE
*     RECORD, ELSE THE DATA IS IGNORED.
#
 
      IF RDFC$CTYP[0] EQ RDFHDRREC
      THEN
        BEGIN  # RDF HEADER #
        IF BFLG EQ 0
        THEN
          BEGIN  # EXTRACT DATA #
          IF RDFH$ID[0] NQ "PFDUMP"
          THEN                       # INVALID FILE #
            BEGIN
            VLERROR(VE"RDFHDR",ABRT);  # ABORT WITH MESSAGE #
            END
 
          RDFDT = RDFC$PDT[0];       # PACKED DATE AND TIME #
          PAR$FM = RDFH$FAM[0];      # RDF FAMILY #
          MP$WD[1] = VLNTC(PAR$FM," ",10);  # FAMILY IN MESSAGE #
          VLMSG(VM"RDFFM");          # ISSUE MESSAGE #
          MP$WD[1] = EDATE(B<24,18>RDFDT);  # EDITED DATE #
          MP$WD[2] = ETIME(B<42,18>RDFDT);  # EDITED TIME #
          VLMSG(VM"RDFDT");          # ISSUE MESSAGE #
          RDFHDROK = TRUE;
          PROCESSED = TRUE;
          END  # EXTRACT DATA #
 
        ELSE
          BEGIN
          PROCESSED = TRUE;
          END
 
        END  # RDF HEADER #
 
#
*     *PFC* EXTRACT RECORD PROCESSING OCCURS IF THE CONTROL WORD
*     TYPE INDICATES IT IS A *PFC* RECORD.
#
 
      IF RDFC$CTYP[0] EQ RDFPFCREC
      THEN
        BEGIN  # *PFC* EXTRACT #
        SBINDX = RDFR$SB[0];         # *PFC* SUBFAMILY #
 
#
*     BUILD AN EXTRACT RECORD FOR THE SELECTED SUBFAMILY AND SM.
#
 
        IF (B<SBINDX,1>PAR$SB EQ 1) AND (B<RDFR$SM,1>PAR$SM EQ 1)
          AND (RDFR$AT[0] EQ ATAS)
        THEN
          BEGIN  # BUILD EXTRACT #
          EXTR$ASA[0] = RDFR$ASA[0];
          EXTR$PFN[0] = RDFR$PFN[0];
          EXTR$UI[0] = RDFR$UI[0];
          EXTR$BKDT[0] = RDFR$UCDT[0];  # BACKUP = UTILITY #
          IF RDFR$UCDT[0] LS RDFR$CMDT[0]
          THEN                       # CONTROL IS MORE RECENT THAN
                                       UTILITY #
            BEGIN
            EXTR$BKDT[0] = RDFR$CMDT[0];  # BACKUP = CONTROL #
            END
 
          EXTR$D[0] = RDFR$D[0];
          EXTR$FLG[0] = RDFR$ASCF[0];
          WRITEW(PFCEXTN[SBINDX],EXTRECORD,RLEXTR,KSTAT);
          END  # BUILD EXTRACT #
 
#
*     FOR AN INVALID *SM*, REPORT PROBLEM.
#
 
      IF (RDFR$ASA[0] NQ 0)
        AND (RDFR$AT[0] EQ ATAS)
        AND (RDFR$SM[0] EQ 0 OR RDFR$SM[0] GR "H")
        THEN
          BEGIN
          TOTALERRS = TOTALERRS + 1;
          RPLINE(RPTFADR," ",0,1,EOPL);  # BLANK LINE #
          BAD$PFN[0] = VLNTC(RDFR$PFN[0]," ",7);  # *PFN* INTO LINE #
          RPLINE(RPTFADR,BADSM,4,50,EOPL);  # ISSUE ERROR LINE #
          BAD$UI[0] = VLNTC(RDFR$UI[0],"XCOD",6);  # UI INTO LINE #
          RPLINE(RPTFADR,BADSM2,4,50,EOPL);  # ISSUE ERROR LINE #
          END
 
        PROCESSED = TRUE;
        END  # *PFC* EXTRACT #
 
#
*     SFM CATALOG RECORDS.
#
 
      IF RDFC$CTYP[0] EQ RDFCATREC
      THEN
        BEGIN  # SFM CATALOG #
        IF BFLG EQ 0                 # BEGINNING OF CATALOG #
        THEN
          BEGIN
          P<PREAMBLE> = LOC(RDFRECORD);
          ZZZV$LFNX[0] = PRM$SUBF[0]+"0";  # APPEND SUBFAMILY TO
                                             *LFN* #
          B<PRM$SUBF[0],1>SFMCATDEF = 1; # FLAG THAT CATALOG EXISTS #
          REWIND(ZZZVALX,RCL);
          END
 
        IF L GR 0
        THEN
          BEGIN
          WRITEW(ZZZVALX,RDFRECORD,L,KSTAT);
          END
 
        IF EFLG EQ 0
        THEN                         # END OF CATALOG, CLOSE IT #
          BEGIN
          WRITEF(ZZZVALX,RCL);
          REWIND(ZZZVALX,RCL);
          END
 
        PROCESSED = TRUE;
        END  # SFM CATALOG #
 
#
*     IF AT END OF FILE, SET THE PROCESSED FLAG.
#
 
      IF RDFC$CTYP[0] EQ RDFEOF
      THEN                           # AT END OF FILE #
        BEGIN
        PROCESSED = TRUE;
        END
 
#
*     UNIDENTIFIED DATA RECORD IN RDF FILE.
#
 
      IF NOT PROCESSED
      THEN
        BEGIN
        VLERROR(VE"RDFUND",NOABT);   # ISSUE MESSAGE #
        END
 
      END  # VLRDF2 #
 
    TERM
PROC VLREQEX(RTYP,RFUNC);
# TITLE VLREQEX - REQUEST TO EXEC.                                    #
 
 
      BEGIN  # VLREQEX #
 
#
**    VLREQEX - SEND REQUEST TO THE M860 EXEC SUBSYSTEM.
*
*     *VLREQEX* FORMATS AND ISSUES THE REQUEST TO EXEC ACCORDING
*     TO THE REQUEST TYPE AND THE REQUEST FUNCTION.  AFTER COMPLETION
*     OF THE SUBSYSTEM REQUEST, *VLREQEX* PROCESSES THE RESPONSE.
*
*     PROC VLREQEX(RTYP,RFUNC)
*
*     ENTRY     (RTYP)            - REQUEST TYPE.
*               (RFUNC)           - REQUEST FUNCTION.
*               (CFIELD)          - CATALOG FIELD TO MODIFY (OPTIONAL).
*               (CONNECTED)       - FLAG INDICATES *SSVAL* CONNECTED TO
*                                   *EXEC*.
*               (PAR$FM)          - FAMILY.
*               (SMINDX)         - SM INDEX.
*               (SBINDX)          - SUBFAMILY INDEX.
*               (ARRAY EXTRECORD) - CONTAINS THE FIXIT FILE RECORD.
*
*     EXIT      (STAT) - RESPONSE CODE FROM THE SYSTEM OR *EXEC*
*                        ON A TYPE 1 REQUEST.
*
*               IF THE RESPONSE INDICATES AN ERROR ON A TYPE 3 REQUEST,
*               THE PROGRAM ABORTS WITH A MESSAGE.
*
*     MESSAGES  * WAITING FOR EXEC.*
*               * UCP CALL ERROR.*
*
*     NOTES     IF THE "CONNECTED" FLAG IS NOT SET, THE REQUEST IS
*               IGNORED.  THIS ALLOWS *SSVAL* TO RUN WHEN EXEC IS NOT
*               PRESENT (IN A LIMITED MODE).
*
*               FOR TYPE 3 RESPONSES, "RESUBMIT" AND "INTERLOCK", AN
*               INFORMATIVE MESSAGE IS ISSUED TO THE B DISPLAY AND THE
*               REQUEST IS RE-ISSUED.
*
#
 
      ITEM RTYP       I;             # REQUEST TYPE #
      ITEM RFUNC      I;             # REQUEST FUNCTION #
 
#
****  PROC VLREQEX - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALLSS;                 # ISSUES A CALLSS REQUEST TO A
                                       SUBSYSTEM #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC VLMSG;                  # ISSUE INFORMATIONAL MESSAGE #
        PROC VLRCL;                  # RECALL #
        PROC ZFILL;                  # ZERO FILLS A CHARACTER ITEM #
        END
 
#
****  PROC VLREQEX - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF LISTING #
 
*CALL COMBFAS
*CALL COMBCPR
*CALL COMBMAP
*CALL COMBUCR
*CALL COMTVLD
*CALL COMTVLF
 
 
 
      ITEM PROCESSED  B;             # CONTROL FLAG #
 
      ARRAY CPRARRAY [0:0] S(CPRLEN);
      ;                              # CALLSS PARAMETER ARRAY #
 
                                               CONTROL EJECT;
 
#
*     IGNORE THIS REQUEST IF NOT CONNECTED TO EXEC.
#
 
      IF NOT CONNECTED
      THEN
        BEGIN
        RETURN;                      # SKIP IF NOT CONNECTED #
        END
 
#
*     BUILD THE PARAMETER ARRAY FOR THE CALLSS MACRO.
#
 
      ZFILL(CPRARRAY,CPRLEN);        # ZERO FILL THE ARRAY #
      P<CPR> = LOC(CPRARRAY);
 
      CPR$RQT[0] = RTYP;             # SET REQUEST TYPE #
      CPR$RQC[0] = RFUNC;            # SET REQUEST FUNCTION #
      CPR$RQI[0] = REQNAME"RQIVALD";  # SET REQUESTOR ID #
      CPR$SSPFLG[0] = TRUE;
      CPR$SSBFLG[0] = TRUE;
      CPR$FAM[0] = PAR$FM;
 
#
*     BUILD TYPE1 FIELDS FOR A *TYP1* REQUEST.
#
 
      IF RTYP EQ TYP"TYP1"
      THEN
        BEGIN
        CPR$WC[0] = TYP1$WC;
        END
 
#
*     BUILD TYPE3 FIELDS FOR A *TYP3* REQUEST.
#
 
      IF (RTYP EQ TYP"TYP3")
      THEN                          # SET WORD COUNT #
        BEGIN
        CPR$WC[0] = TYP3$WC;
        END
 
      IF (RTYP EQ TYP"TYP3")
        AND (RFUNC NQ REQTYP3"REL$SETUP")
      THEN
        BEGIN  # TYP3 REQUEST #
        CPR$WC[0] = TYP3$WC;
        CPR$CSU[0] = SMINDX;   # *SM* FROM FIXIT FILE RECORD #
        CPR$SUB[0] = SBINDX;         # SUBFAMILY #
        CPR$FAM[0] = PAR$FM;
 
        CPR$FCT[0] = EXTR$FCT[0];
        CPR$AU[0] = EXTR$AU[0];
 
#
*     BUILD SMMAP FIELDS IF IT IS AN *UPDATE MAP* FUNCTION.
#
 
        IF RFUNC EQ REQTYP3"UPD$MAP"
        THEN
          BEGIN
          CPR$Y[0] = PROB$Y[0];
          CPR$Z[0] = PROB$Z[0];
          CPR$MAPENT[0] = PROB$MAPEN[0];
          P<SMUMAP> = LOC(CPR$MAPENT[0]);
          CM$FLAG1[0] = TRUE;
          END
 
#
*     BUILD CATALOG FIELDS IF IT IS AN "UPDATE CATALOG" FUNCTION.
#
 
        IF RFUNC EQ REQTYP3"UPD$CAT"
        THEN
          BEGIN
          CPR$FLD[0] = CFIELD;       # CATALOG FIELD NAME FLAG #
          CPR$VAL[0] = 1;
          END
 
        END  # TYP3 REQUEST #
 
#
*     ISSUE REQUEST TO EXEC.
#
 
      PROCESSED = FALSE;
      REPEAT WHILE NOT PROCESSED
      DO
        BEGIN  # EXEC REQUEST #
        CPR$RQR[0] = 0;              # INITIALIZE RESPONSE CODE #
        CPR$C[0] = FALSE;            # INITIALIZE COMPLETE BIT #
        CALLSS(SSID$VL,CPR,RCL);
 
#
*     RE-ISSUE IF EXEC RETURNS A "RE-ISSUE" STATUS.
#
 
        IF (RTYP EQ TYP"TYP3") AND (CPR$RQR[0] EQ RESPTYP3"RESUB$REQ")
          THEN
          BEGIN
          VLMSG(VM"WAITEX");         # ISSUE MESSAGE #
          TEST DUMMY;                # REPEAT THE REQUEST #
          END
 
#
*     DELAY AND RE-ISSUE IF EXEC RETURNS "FILE INTERLOCKED" STATUS.
#
 
        IF (RTYP EQ TYP"TYP3") AND (CPR$RQR[0] EQ RESPTYP3"C$M$INTLCK")
        THEN
          BEGIN
          VLMSG(VM"WAITEX");         # ISSUE MESSAGE #
          VLRCL(WAITEX);             # DELAY AWHILE #
          TEST DUMMY;                # REPEAT THE REQUEST #
          END
 
        PROCESSED = TRUE;
        END  # EXEC REQUEST #
 
      VLMSG(VM"CLEARB");
 
#
*     ABORT IF THE REQUEST WAS A TYPE3 AND EXEC RESPONDED
*     WITH AN ERROR.
#
 
      STAT = CPR$RQR[0];             # GET EXEC RESPONSE #
      IF RTYP EQ TYP"TYP3" AND (STAT NQ 0)
        AND STAT NQ RESPTYP3"NO$SUB$CAT"
        AND CPR$RQC[0] NQ REQTYP3"REL$SETUP"
      THEN
        BEGIN
        VLERROR(VE"UCPERR",ABRT);    # ABORT WITH MESSAGE #
        END
 
#
*     RETURN NUMBER OF FILES RELEASED.
#
 
      IF (RTYP EQ TYP"TYP3")
        AND (RFUNC EQ REQTYP3"REL$SETUP")
      THEN
        BEGIN
        NFILER = CPR$RELC[0];
        END
 
#
*     RETURN THE SYSTEM RESPONSE CODE IF THE REQUEST WAS A
*     TYPE1 AND THE SYSTEM RETURNED AN ERROR CODE.
#
 
      IF CPR$ES[0] NQ 0 AND (RTYP EQ TYP"TYP1")
      THEN
        BEGIN
        STAT = CPR$ES[0];            # RETURN SYSTEM RESPONSE #
        END
 
      RETURN;
      END  # VLREQEX #
 
    TERM
PROC VLRPT(GROUP);
# TITLE VLRPT - VALIDATION REPORT.                                    #
 
 
      BEGIN  # VLRPT #
 
#
**    VLRPT - VALIDATION REPORT.
*
*     *VLRPT* GENERATES A REPORT OF PROBLEMS DETECTED IN THE
*     PREVIOUS STEPS.  PROBLEMS ARE IDENTIFIED BY THE RECORDS
*     ON THE PROBLEM FILE AND BY ENTRIES IN THE *VT* TABLE
*     THAT HAVE ERROR FLAGS ON.  THE PROBLEMS ARE FORMATTED
*     INTO DETAIL LINES AND WRITTEN TO THE REPORT FILE VIA
*     THE REPORT FORMATTER ROUTINES.
*
*     FOR PROBLEMS/ORPHANS THAT REQUIRE CATALOG FIXES(REPAIRS OR
*     RELEASES), A FIXIT FILE RECORD IS WRITTEN.
*
*     PROC VLRPT
*
*     ENTRY     (RPTFADR)        - ADDRESS OF THE REPORT FILE *FET*.
*               (GROUP)          - GROUP BEGIN PROCESSED.
*               (VTFIRST)        - INDEX OF FIRST ENTRY IN *VT*.
*               (VTLAST)         - INDEX OF LAST ENTRY IN *VT*.
*               (ARRAY PROBFILE) - PROBLEM FILE *FET*.
*
*     EXIT      (CNTORPHANS) - NUMBER OF TROUBLE-FREE ORPHANS DETECTED.
*               (RELEASABLE) - NUMBER OF AU-S ALLOCATED TO ORPHANS.
*               (TOTALERR)   - TOTAL VALIDATION ERRORS.
*
*               RECORDS ARE WRITTEN TO THE FIXIT FILE IF DESIRED.
*
*               DETAIL LINES ARE ISSUED TO THE REPORT FILE FOR PROBLEMS
*               DETECTED.
*
*     NOTES     SEE *SSVAL* DOCUMENTATION FOR A DESCRIPTION OF THE
*               REPORT FILE ENTRIES.
*
*               THE DETAIL LINES TO BE ISSUED ARE SELECTED BY THE
*               TYPE OF PROBLEM BEING PROCESSED.
*
*               THE DETAIL LINES ARE TO IDENTIFY THE PROBLEM TYPE,
*               THE IDENTITY OF THE SPECIFIC ENTRY (Y ORDINAL, Z
*               ORDINAL, PFN, UI, ETC.) AND THE ERROR TEXT.
*
*               FOR PROBLEM ENTRIES THAT INVOLVE CHAINS, THE CHAIN
*               ENTRIES ARE REPORTED BY CALLING THE ROUTINE *VLSCH*.
*
*               THE VARIABLE INFORMATION FOR EACH DETAIL LINE IS
*               INSERTED INTO THE LINE USING A CONVERSION ROUTINE
*               *VLNTC* TO GET DISPLAY CODE (LEFT-JUSTIFIED) DATA WHEN
*               NECESSARY.
*
#
 
#
****  PROC VLRPT - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        FUNC EDATE C(10);            # EDIT DATE FROM PACKED FORMAT #
        FUNC ETIME C(10);            # EDIT TIME FROM PACKED FORMAT #
        PROC READ;                   # INTERFACE TO *READ* MACRO #
        PROC READW;                  # INTERFACE TO *READW* MACRO #
        PROC REWIND;                 # INTERFACE TO *REWIND* MACRO #
        PROC RPEJECT;                # STARTS A NEW REPORT PAGE #
        PROC VLRPTL;                 # ISSUE REPORT LINE #
        PROC VLSUBHD;                # ISSUE REPORT SUBHEADING #
        FUNC VLNTC C(10);            # NUMERIC TO CHARACTER
                                       CONVERSION #
        PROC VLSCH;                  # SCAN CHAIN FOR REPORT #
        PROC VLWFIX;                 # WRITE FIX FILE RECORD #
        END
 
#
****  PROC VLRPT - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTINGS #
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLV
 
      DEF LIST       #TRUE#;         # SELECT CHAIN LIST #
      DEF NOLIST     #FALSE#;        # SELECT NO CHAIN LIST #
 
      ITEM RECHAR     C(10);         # CHARACTER TYPE TEMPORARY #
      ITEM GROUP      U;             # GROUP BEING PROCESSED #
      ITEM FCT        U;             # *FCT* ORDINAL #
 
 
#
*     THE FOLLOWING ARRAYS ARE FORMATTED LINES FOR THE REPORT FILE.
*     THE VARIABLE PORTION IS UPDATED WHEN THE LINE IS TO BE USED
*     DURING THE PROBLEM RECORD PROCESSING.
#
 
      ARRAY RLINE1 [0:0] S(2);
        BEGIN
        ITEM RLINE1$DEF   C(00,00,20) = ["Y  = NN"];
        ITEM RLINE1$YN    C(00,30,02);
        END
 
      ARRAY RLINE2 [0:0] S(2);
        BEGIN
        ITEM RLINE2$DEF   C(00,00,20) = ["Z  = NN"];
        ITEM RLINE2$ZN    C(00,30,02);
        END
 
      ARRAY RLINE2A [0:0] S(2);
        BEGIN
        ITEM RLINE2A$DEF  C(00,00,20) = ["CM = A-"];
        ITEM RLINE2A$CM   C(00,30,02);
        END
 
      ARRAY RLINE3 [0:0] S(2);
        BEGIN
        ITEM RLINE3$DEF   C(00,00,20) = ["CSN= CSNNAMEX"];
        ITEM RLINE3$CSN   C(00,30,08);
        END
 
      ARRAY RLINE4 [0:0] S(2);
        BEGIN
        ITEM RLINE4$DEF   C(00,00,20) = ["FCT= NNNN"];
        ITEM RLINE4$FCT   C(00,30,04);
        END
 
      ARRAY RLINE5 [0:0] S(2);
        BEGIN
        ITEM RLINE5$DEF   C(00,00,20) = ["PF = PFNNAME"];
        ITEM RLINE5$PFN   C(00,30,07);
        END
 
      ARRAY RLINE6 [0:0] S(2);
        BEGIN
        ITEM RLINE6$DEF   C(00,00,20) = ["UI = NNNNNN "];
        ITEM RLINE6$UI    C(00,30,06);
        END
 
      ARRAY RLINE7 [0:0] S(2);
        BEGIN
        ITEM RLINE7$DEF   C(00,00,20) = ["DI = N"];
        ITEM RLINE7$D     C(00,30,01);
        END
 
      ARRAY RLINE8 [0:0] S(3);
        BEGIN
        ITEM RLINE8$DEF   C(00,00,30) = ["BU = MO-DA-YR HR.MN.SC"];
        ITEM RLINE8$BUDA  C(00,24,10);
        ITEM RLINE8$BUTI  C(01,24,10);
        END
 
      ARRAY RLINE9 [0:0] S(1);
        BEGIN
        ITEM RLINE9$DEF   C(00,00,10) = ["000-0000"];
        ITEM RLINE9$FCT   C(00,00,03);
        ITEM RLINE9$AU    C(00,24,04);
        END
 
                                               CONTROL EJECT;
 
 
#
*     INITIALIZE.
#
 
      SCDTLH = FALSE;                # DETAIL HEADING FLAG #
 
      REWIND(PROBFILE,RCL);
      READ(PROBFILE,NRCL);
 
#
*     PROCESS EACH PROBLEM FROM THE RECORDS ON THE PROBLEM FILE.
*     THE PROCESS FOR EACH PROBLEM IS TO -
*      - FORMAT THE SELECTED REPORT LINES AND WRITE THEM TO THE
*        REPORT FILE USING THE REPORT FORMATTER VIA THE VLRPTL
*        ROUTINE.  THE CALLING SEQUENCE TO VLRPTL IS THE SAME AS FOR
*        THE REPORT FORMATTER.
*      - WRITE A RECORD TO THE FIXIT FILE IDENTIFYING THE TYPE OF
*        CATALOG REPAIR/RELEASE ACTION VIA THE RECORD TYPE.
*      - INCREMENT THE TOTAL ERRORS COUNTER.
#
 
      STAT = 0;
      REPEAT WHILE STAT EQ OK
      DO
        BEGIN  # PROBLEM PROCESSING #
        READW(PROBFILE,EXTRECORD,RLPROB,STAT);  # READ PROBLEM FILE #
        IF STAT NQ OK
        THEN
          BEGIN
          TEST DUMMY;                # EOR, EOF, EOI OR ERROR #
          END
 
#
*     START THE REPORT LINE WITH THE ERROR TYPE FROM THE FIXIT
*     FILE RECORD TYPE.  WRITE THE ERROR TYPE TO THE REPORT FILE
*     USING THE *CONTINUE LINE* OPTION OF THE REPORT FORMATTER.
#
 
        VLRPTL(RPTFADR," ",0,1,EOPL);  # A BLANK LINE #
        RECHAR = VLNTC(PROB$RT[0],"XCOD",1);
        VLRPTL(RPTFADR,RECHAR,8,1,COPL);  # ERROR TYPE #
 
 
#
*     FORMAT IDENTIFICATION LINES IF THE PROBLEM TYPE IS *FCT* OR
*     *SM* BY FILLING THE *FCT*, Y COORDINATE, Z COORDINATE AND CSN
*     INTO THE REPORT LINES.
#
 
        IF PROB$RT[0] EQ REC"FCT" OR PROB$RT[0] EQ REC"SM"
        THEN
          BEGIN
          RLINE4$FCT[0] = VLNTC(EXTR$FCT[0] + ZFD,"XCDD",4);
          RLINE1$YN[0] = VLNTC(PROB$Y[0]+ZFD,"XCDD",2);
          RLINE2$ZN[0] = VLNTC(PROB$Z[0]+ZFD,"XCDD",2);
          RLINE2A$CM[0] = VLNTC(PROB$CM[0]," ",2);
          RLINE3$CSN[0] = VLNTC(PROB$CSN[0]," ",8);
          END
 
 
#
*     PROCESS PROBLEM RECORD TYPE *FCT* (*SM* ORDINAL ERROR IN *FCT*
*     ENTRY).
#
 
        IF PROB$RT[0] EQ REC"FCT"
        THEN
          BEGIN
          VLRPTL(RPTFADR,RLINE4,11,20,EOPL);  # *FCT* ID #
          VLRPTL(RPTFADR,RLINE1,11,20,EOPL);  # Y ORD ID #
          VLRPTL(RPTFADR,RLINE2,11,20,EOPL);  # Z ORD ID #
          VLRPTL(RPTFADR,RLINE3,11,20,COPL);  # CSN ID #
          VLRPTL(RPTFADR,ECORD,50,40,EOPL);  # ERROR TEXT #
 
          VLWFIX(REC"FCT");          # BUILD FIXIT FILE RECORD #
          TOTALERRS = TOTALERRS + 1;
          END
 
#
*     PROCESS PROBLEM TYPE *SM* (*FCT* ORDINAL ERROR IN SMMAP
*     ENTRY).
#
 
        IF PROB$RT[0] EQ REC"SM"
        THEN
          BEGIN
          VLRPTL(RPTFADR,RLINE1,11,20,EOPL);  # Y ORD ID #
          VLRPTL(RPTFADR,RLINE2,11,20,EOPL);  # Z ORD ID #
          VLRPTL(RPTFADR,RLINE3,11,20,EOPL);  # CSN ID #
          VLRPTL(RPTFADR,RLINE4,11,20,COPL);  # *FCT* ID #
          VLRPTL(RPTFADR,EFORD,50,40,EOPL);  # ERROR TEXT #
 
          TOTALERRS = TOTALERRS + 1;
          VLWFIX(REC"SM");          # BUILD FIXIT FILE RECORD #
          END
 
#
*     FORMAT THE IDENTIFICATION FIELDS IF THE PROBLEM TYPE IS
*     *ASA* OR *OTHR*.
#
 
        IF PROB$RT[0] EQ REC"ASA" OR PROB$RT[0] EQ REC"OTHR"
        THEN
          BEGIN  # ISSUE ID LINES #
          IF VTLAST GQ VTFIRST
          THEN
            BEGIN  # CHECK *VT* ENTRY #
            P<VTLINK> = LOC(VTPTR);  # BUILD LINK TO *VT* ENTRY #
          VTL$GRT[0] = EXTR$GPT[0];
            VTL$AU[0] = EXTR$AU[0];
            VTEN$WORD[0] = VT$ITEM[VTL$WORD[0]];  # GET *VT* ENTRY #
            IF VTEN$PROB[0] EQ VPT1
            THEN
              BEGIN
              VLRPTL(RPTFADR," ",8,1,COPL);  # SCATTERED ERROR TYPE #
              END
 
            END  # CHECK *VT* ENTRY #
 
          RLINE5$PFN[0] = VLNTC(EXTR$PFN[0]," ",7);  # *PFN* #
          RLINE6$UI[0] = VLNTC(EXTR$UI[0],"XCOD",6);  # UI #
          RLINE7$D[0] = "N";         # DISK IMAGE = NO #
          IF EXTR$D[0] NQ 0
          THEN
            BEGIN
            RLINE7$D[0] = "Y";       # DISK IMAGE = YES #
            END
 
          RLINE8$BUDA[0] = EDATE(EXTR$BKDA[0]);  # BACKUP DATE #
          RLINE8$BUTI[0] = ETIME(EXTR$BKTI[0]);  # BACKUP TIME #
 
#
*     WRITE THE FORMATTED LINES TO THE REPORT FILE.
#
 
          VLRPTL(RPTFADR,RLINE5,11,20,EOPL);  # *PFN* ID #
          VLRPTL(RPTFADR,RLINE6,11,20,EOPL);  # UI #
          VLRPTL(RPTFADR,RLINE8,11,30,EOPL);  # BACK UP DATE-TIME #
          VLRPTL(RPTFADR,RLINE7,11,20,COPL);  # DISK IMAGE FLAG #
          END  # ISSUE ID LINES #
 
#
*     PROCESS THE PROBLEM TYPE *ASA* (INVALID ASA).
#
 
        IF PROB$RT[0] EQ REC"ASA"
        THEN
          BEGIN
          FCT = GROUP * 16 + VTL$GRT[0];
          RLINE9$FCT[0] = VLNTC(FCT + ZFD,"XCDD",3);
          RLINE9$AU[0] = VLNTC(EXTR$AU[0]+ZFD,"XCDD",4);
          VLRPTL(RPTFADR,RLINE9,34,7,COPL);  # FCT-AU #
          VLRPTL(RPTFADR,EASA,50,20,EOPL);  # ERROR TEXT #
 
          TOTALERRS = TOTALERRS + 1;
          VLWFIX(REC"ASA");          # BUILD FIXIT FILE RECORD #
          END
 
#
*     PROCESS THE PROBLEM TYPE *OTHR* (PFC OWNER WITH PROBLEM
*     SFM FILE).
#
 
        IF PROB$RT[0] EQ REC"OTHR"
        THEN
          BEGIN
          P<VTLINK> = LOC(VTPTR);    # BUILD LINK TO *VT* ENTRY #
          VTL$GRT[0] = EXTR$GPT[0];
          VTL$AU[0] = EXTR$AU[0];
          VTEN$WORD[0] = VT$ITEM[VTL$WORD[0]];  # GET *VT* ENTRY #
          IF VTEN$TYP2[0] OR VTEN$TYP4[0]
          THEN                       # TYPE 2 OR TYPE 4 VALIDATION
                                       ERROR #
            BEGIN
            TOTALERRS = TOTALERRS + 1;
            VLWFIX(REC"OTHR");       # BUILD FIXIT FILE ENTRY #
            END
 
          VLSCH(LIST,GROUP);
          END
 
 
        END  # PROBLEM PROCESSING #
 
                                               CONTROL EJECT;
 
#
*     SCAN THE VALIDATION TABLE (VT) - TO REPORT REMAINING PROBLEMS.
*
*                                    - TO DETECT TROUBLE-FREE ORPHANS.
#
 
      SLOWFOR VTPTR = VTFIRST STEP 1 UNTIL VTLAST
      DO
        BEGIN  # *VT* SCAN #
        VTEN$WORD[0] = VT$ITEM[VTPTR];  # GET *VT* ENTRY #
 
#
*     PROCESS TROUBLE-FREE ORPHANS.
#
 
        IF VTEN$HOC[0] AND NOT VTEN$OWN[0] AND NOT VTEN$TYP4[0]
        THEN
          BEGIN
          VLWFIX(REC"TFORPH");       # BUILD FIXIT FILE ENTRY #
          VLSCH(NOLIST,GROUP);
 
          RELEASABLE = RELEASABLE + AUCOUNT;
          CNTORPHANS = CNTORPHANS + 1;
          TEST VTPTR;
          END
 
#
*     PROCESS PROBLEM CHAINS.  PROBLEM CHAINS ARE -
*      - ORPHAN CHAINS WITH PROBLEMS.
*      - CHAINS THAT ARE OWNED, HAVE PROBLEMS, AND ARE NOT
*        YET REPORTED.
#
 
        IF (VTEN$HOC[0] AND NOT VTEN$OWN[0] AND VTEN$TYP4[0]) OR
          (VTEN$OWN[0] AND (VTEN$PROB[0] NQ 0) AND NOT VTEN$RPTED[0])
        THEN
          BEGIN
          TOTALERRS = TOTALERRS + 1;
          VLWFIX(REC"BADORPH");      # BUILD FIXIT FILE ENTRY #
          VLRPTL(RPTFADR,"0",0,1,COPL);  # 2 BLANK LINES #
          VLRPTL(RPTFADR,"5",8,1,COPL);  # ERROR TYPE #
          VLRPTL(RPTFADR,"ORPHAN",11,6,COPL);
          VLSCH(LIST,GROUP);
          TEST VTPTR;
          END
 
#
*     PROCESS FRAGMENT CHAINS.  FRAGMENT CHAINS ARE IDENTIFIED BY THE
*       START OF FRAGMENT FLAG.
#
 
        IF VTEN$SOF[0] AND VTEN$ALOC[0]
        THEN
          BEGIN
          TOTALERRS = TOTALERRS + 1;
          VLWFIX(REC"FRAG");         # BUILD FIXIT FILE ENTRY #
          VLRPTL(RPTFADR,"0",0,1,COPL);
          VLRPTL(RPTFADR,"6",8,1,COPL);
          VLRPTL(RPTFADR,"FRAGMENT",11,8,COPL);
          VLSCH(TRUE,GROUP);
          TEST VTPTR;
          END
 
#
*     PROCESS NOT ALLOCATED ENTRIES (NOT ON CHAIN) THAT CONTAIN
*       TYPE 4 VALIDATION ERRORS.
#
 
        IF NOT VTEN$ALOC[0] AND VTEN$TYP4[0]
        THEN
          BEGIN
          TOTALERRS = TOTALERRS + 1;
          VLWFIX(REC"BADHOLE");
          VLRPTL(RPTFADR,"0",0,1,COPL);
          VLRPTL(RPTFADR,"7",8,1,COPL);
          VLRPTL(RPTFADR,"UNALLOCATED",11,11,COPL);
          VTEN$POINT[0] = VTPTR;     # INPUT TO *VLSCH* #
          VLSCH(TRUE,GROUP);
          TEST VTPTR;
          END
 
        END  # *VT* SCAN #
 
#
*     END OF REPORT PROCESS
#
 
      END  # VLRPT #
 
    TERM
PROC VLRPTL(P1,P2,P3,P4,P5);
 
# TITLE VLRPTL - ISSUE REPORT LINE.                                   #
 
      BEGIN  # VLRPTL #
 
#
**    VLRPTL - ISSUE REPORT LINE.
*
*     *VLRPTL* ISSUES THE REPORT FILE LINES FOR *VLRPT*.  THE
*     PURPOSE OF THIS ROUTINE IS TO SIMPLY GET THE SUBCATALOG
*     DETAIL HEADING LINE ISSUED BEFORE THE FIRST DETAIL LINE
*     FROM *VLRPT*.
*
*     PROC VLRPTL(P1,P2,P3,P4,P5)
*
*     ENTRY     (P1)     - PARAMETER 1 ( PARAMETERS TO PASS THROUGH
*               (P2)     - PARAMETER 2   TO THE REPORT FORMATTER
*               (P3)     - PARAMETER 3    *RPLINE* ).
*               (P4)     - PARAMETER 4.
*               (P5)     - PARAMETER 5.
*               (SCDTLH) - SUBCATALOG DETAIL HEADING FLAG.
*
*     EXIT      (SCDTLH)  - SUBCATALOG DETAIL HEADING FLAG.
*               (SCRPTED) - SUBCATALOG REPORTED FLAG.
*
*               REPORT LINE WAS WRITTEN TO THE REPORT FILE VIA
*               THE REPORT FORMATTER.
*
*     NOTES     SCDTLH GETS TURNED ON AND OFF IN THE INTERSECTING
*               CHAIN REPORT PROCESS AND IN THE PROBLEM REPORT PROCESS.
*
*               SCRPTED IS A FLAG TO INDICATE IF EITHER OF THE ABOVE
*               REPORTS OCCURRED WHICH THEN SUPPRESSES THE SUBSEQUENT
*               "GOOD" SUBCATALOG HEADING.
*
#
 
      ITEM P1         I;             # PARAMETER 1 FOR RPLINE #
      ITEM P2         I;             # PARAMETER 2 FOR RPLINE #
      ITEM P3         I;             # PARAMETER 3 FOR RPLINE #
      ITEM P4         I;             # PARAMETER 4 FOR RPLINE #
      ITEM P5         I;             # PARAMETER 5 FOR RPLINE #
 
#
****  PROC VLRPTL - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC VLSUBHD;                # ISSUE REPORT SUBHEADING #
        END
 
#
****  PROC VLRPTL - XREF LIST END.
#
 
      DEF LISTCON #0#;
 
*CALL COMBFAS
*CALL COMTVLD
 
                                               CONTROL EJECT;
 
#
*     IF THE PROBLEM REPORT DETAIL HEADING IS NOT YET PRINTED,
*     PRINT IT.
#
 
      IF NOT SCDTLH
      THEN
        BEGIN
        VLSUBHD(SHTYP"PRPT");        # ISSUE DETAIL HEADING #
        SCRPTED = TRUE;              # SET SUBCATALOG REPORTED FLAG #
        SCDTLH = TRUE;               # SET DETAIL HEADING PRINTED
                                       FLAG #
        END
 
#
*     PRINT THE REPORT LINE.
#
 
      RPLINE(P1,P2,P3,P4,P5);
 
 
      END  # VLRPTL #
 
    TERM
PROC VLSCH(LISTOPT,GROUP);
# TITLE VLSCH - SCAN CHAIN FOR REPORT.                                #
 
 
      BEGIN  # VLSCH #
 
      ITEM LISTOPT    B;             # TRUE - LIST EACH CHAIN ENTRY #
 
#
****  PROC VLSCH - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        FUNC VLNTC C(10);            # NUMERIC TO CHARACTER
                                       CONVERSION #
        END
 
#
****  PROC VLSCH - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLV
 
      ITEM ENDCHAIN   B;             # END OF CHAIN FLAG #
      ITEM FCT        U;             # *FCT* ORDINAL #
      ITEM GROUP      U;             # GROUP PROCESSED #
      ITEM HOCPTR     I;             # HEAD OF CHAIN POINTER #
      ITEM I          I;             # TEMPORARY VARIABLE #
      ITEM J          I;             # TEMPORARY VARIABLE #
      ITEM LFADDR     I;             # RPT FET ADDR IF LISTOPT = TRUE #
      ITEM PRTFLAG    B;             # PRINT FLAG #
 
#
*     FORMATTED LINE FOR THE REPORT FILE FOR THE CHAIN IDENTIFICATION.
#
 
      ARRAY CHAINID [0:0] S(2);      # CHAIN ID REPORT LINE #
        BEGIN
        ITEM CHAIN$DEF  C(00,00,20) = ["000-0000 A 0"];
        ITEM CHAIN$FCT  C(00,00,03);  # *FCT* #
        ITEM CHAIN$AU   C(00,24,04);  # *AU* #
        ITEM CHAIN$AF   C(00,54,01);
        ITEM CHAIN$MID  C(01,00,02);  # CHAIN STATUS #
        ITEM CHAIN$HOC  C(01,00,01);  # HEAD OF CHAIN #
        ITEM CHAIN$EOC  C(01,06,01);  # END OF CHAIN #
        END
 
      BASED
      ARRAY REM [0:0] S(1);
      ;                              # REPORT ERROR MSG #
 
                                               CONTROL EJECT;
#
*     SET THE REPORT FILE FET ADDRESS IF THE CHAIN ENTRY ID
*     IS TO BE LISTED IN THE REPORT FILE.
#
 
      IF LISTOPT
      THEN
        BEGIN
        LFADDR = RPTFADR;            # REPORT THE CHAIN ENTRIES #
        END
 
      ELSE
        BEGIN
        LFADDR = 0;                  # TURN REPORT OFF #
        END
 
      I = VTPTR;                     # STARTING INDEX #
      HOCPTR = VTEN$POINT[0];        # SAVE START OF CHAIN ID #
      AUCOUNT = 0;
 
#
*     PROCESS EACH ENTRY IN CHAIN STARTING WITH GIVEN ENTRY (VTPTR).
#
 
      ENDCHAIN = FALSE;
      REPEAT WHILE NOT ENDCHAIN
      DO
        BEGIN  # *VT* CHAIN PROCESS #
 
#
*     CALCULATE SFM SPACE IN CHAIN
#
 
        AUCOUNT = AUCOUNT + 1;
 
#
*     BUILD THE CHAIN IDENTIFICATION FOR THE REPORT.
#
 
        P<VTLINK> = LOC(I);          # TO EXTRACT FCT,STRM FROM LINK #
        FCT = GROUP * 16 + VTL$GRT[0];
        CHAIN$FCT[0] = VLNTC(FCT + ZFD,"XCDD",3);
        CHAIN$AU[0] = VLNTC(VTL$AU[0]+ZFD,"XCDD",4);
        CHAIN$AF[0] = "U";           # UNALLOCATED #
        IF VTEN$ALOC[0]
        THEN                         # CHAIN ENTRY IS ALLOCATED #
          BEGIN
          CHAIN$AF[0] = "A";         # SET ALLOCATED #
          END
 
        CHAIN$MID[0] = "--";         # SET CHAIN STATUS #
        IF VTEN$HOC[0]
        THEN
          BEGIN
          CHAIN$HOC[0] = "H";        # SET HEAD OF CHAIN #
          END
 
        IF VTEN$EOC[0]
        THEN
          BEGIN
          CHAIN$EOC[0] = "E";        # SET END OF CHAIN #
          END
 
        RPLINE(LFADDR,CHAINID,34,14,COPL);  # ISSUE CHAIN ID #
 
#
*     SCAN THE *VT* ENTRY FOR ERRORS (BITS VPS THRU VPX IN THE
*       *VT* ENTRY).  FOR EACH VALIDATION ERROR FLAG THAT IS SET,
*       GET THE ASSOCIATED ERROR MESSAGE AND ISSUE IT TO THE REPORT.
#
 
        PRTFLAG = FALSE;
        SLOWFOR J = VPS STEP 1 UNTIL VPX
        DO
          BEGIN
          IF B<J,1>VTEN$WORD[0] EQ 1 AND (VTER$MSG[J] NQ "0")
          THEN
            BEGIN
            P<REM> = LOC(VTER$MSG[J]);  # GET ERROR TEXT #
            RPLINE(LFADDR,REM,50,35,EOPL);  # ISSUE TO REPORT #
            PRTFLAG = TRUE;          # SET LINE PRINTED FLAG #
            END
 
          END
 
#
*     IF NO ERRORS WERE FOUND, THE CHAIN ID LINE HAS NOT YET
*       BEEN PRINTED.  (IT WAS ISSUED USING THE "CONTINUE LINE"
*       OPTION).
#
 
        IF NOT PRTFLAG
        THEN
          BEGIN
          RPLINE(LFADDR,0,0,0,EOPL);  # PRINT THE LINE #
          END
 
#
*     DETERMINE IF AT END-OF-CHAIN.
#
 
        ENDCHAIN = VTEN$EOC[0] OR NOT VTEN$ALOC[0]  ##
          OR VTEN$LINK[0] EQ 0 OR VTEN$LINK[0] EQ HOCPTR;
 
#
*     UPDATE THIS ENTRY.
#
 
        VTEN$RPTED[0] = TRUE;
        VT$ITEM[I] = VTEN$WORD[0];   # STORE THE *VT* ENTRY #
 
#
*     GET NEXT AU IN CHAIN.
#
 
        IF NOT ENDCHAIN
        THEN
          BEGIN  # GET NEXT AU #
          I = VTEN$LINK[0];
          IF I GR VTLAST
          THEN                       # INVALID LINK #
            BEGIN
            ENDCHAIN = TRUE;         # FORCE END OF CHAIN #
            P<VTLINK> = LOC(I);      # TO GET FCT,STRM FROM LINK #
            FCT = GROUP * 16 + VTL$GRT[0];
            CHAIN$FCT[0] = VLNTC(FCT + ZFD,"XCDD",3);
            CHAIN$AU[0] = VLNTC(VTL$AU[0] + ZFD,"XCDD",4);
            RPLINE(LFADDR,CHAINID,34,8,COPL);  # REPORT ID #
            RPLINE(LFADDR,ELNK,50,15,EOPL);  # INVALID LINK #
            END
 
          ELSE
            BEGIN
            VTEN$WORD[0] = VT$ITEM[I];  # GET NEXT AU FROM *VT* #
            END
 
          END  # GET NEXT AU #
 
        END  # *VT* CHAIN PROCESS #
 
      END  # VLSCH #
 
    TERM
PROC VLSUBFM;
 
# TITLE VLSUBFM - SUBFAMILY VALIDATION.                               #
 
      BEGIN  # VLSUBFM #
 
#
**    VLSUBFM - SUBFAMILY VALIDATION.
*
*     *VLSUBFM* CONTROLS THE VALIDATION PROCESS FOR A
*     GIVEN SUBFAMILY.
*
*     PROC VLSUBFM
*
*     ENTRY     (DEF$FAM)       - THE DEFAULT FAMILY.
*               (MEM$MAX)       - MAXIMUM MEMORY ALLOWED FOR THE JOB.
*               (MEM$MIN)       - MEMORY REQUIRED FOR THE PROGRAM.
*               (PAR$AM)        - AM OPTION.
*               (PAR$FM)        - FAMILY BEING VALIDATED.
*               (PAR$RF)        - *RDF* FILE NAME.
*               (SBINDX)        - SUBFAMILY BEING PROCESSED.
*               (ARRAY VLCTLFN) - SFM CATALOG LOCAL FILE NAME.
*               (ARRAY VLPFN)   - SFM CATALOG PERMANENT FILE NAME.
*
*     EXIT      THE SUBFAMILY WAS VALIDATED AND DESCRIPTIVE LINES
*               WRITTEN TO THE REPORT FILE.  THE FIXIT FILE RECORDS
*               (IDENTIFYING REPAIRS/RELEASES FOR THE SUBFAMILY) WERE
*               WRITTEN.
*
*     MESSAGES  * FAMILY NOT FOUND IN SYSTEM.*
*               * WAITING FOR FILE FILENAME.*
*               * SFM CATALOG OPEN ERROR.*
*               * VALIDATING SB=N SM=X.*
*               * SMMAP OPEN ERROR.*
*               * REQUIRED FL EXCEEDS JOB MAX.*
*               * SSVAL ABNORMAL, VLSUBFM.*
*
*     NOTES     *VLSUBFM*:
*
*               CALLS *ASINIT* TO INITIALIZE FIELDS FOR THE
*               SFM CATALOG AND SMMAP ACCESS ROUTINES.
*
*               OPENS THE SFM CATALOG FILE FOR THE SUBFAMILY
*                 (EITHER THE LIVE CATALOG IS ATTACHED AND OPENED
*                 OR THE LOCAL FILE CREATED FROM THE *RDF* FILE IS
*                 OPENED).
*
*               VALIDATES EACH SELECTED *SM* THAT IS SELECTED
*                 IN THE *SM* PARAMETER.
*
*                 - OPENS THE PROBLEM FILE.
*                 - OPENS THE SMMAP FILE (IF AM PARAMETER).
*                 - GETS MEMORY SPACE FOR THE *VT* TABLE.
*                 - INITIALIZES THE *VLCMAP* ARRAY.
*                 - CALLS *VLBLDVT* TO BUILD THE *VT* TABLE.
*                 - CALLS *VLAMSF* TO ANALYZE THE SFM DATA
*                   IN THE *VT*.
*                 - CALLS *VLAPFC* TO ANALYZE THE *PFC* DATA IN
*                   THE *PFC* EXTRACT FILES.
*                 - CLOSES THE PROBLEM FILE.
*                 - CALLS *VLRPT* TO GENERATE THE PROBLEM REPORT.
*                 - CLOSES THE SMMAP (IF OPENED).
*                 - ISSUES A SUBCATALOG "GOOD" HEADING ON THE
*                   REPORT FILE IF NO ERRORS WERE DETECTED IN
*                   PREVIOUS STEPS.
*               CLOSES THE SFM CATALOG FILE.
#
 
 
#
**** PROC VLSUBFM - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC SSINIT;
        PROC CINTLK;                 # GET/RELEASE CATALOG INTERLOCK #
        PROC COPEN;                  # OPEN CATALOG #
        PROC CCLOSE;
        PROC CRDAST;                 # READ *AST* #
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC MCLOSE;                 # TERMINATE MAP REFERENCE BY
                                       CALLER #
        PROC MOPEN;                  # EXTABLISH CALLER ACCESS TO MAP
                                       FILE #
        PROC MEMORY;                 # REQUEST FIELD LENGTH CHANGE #
        PROC PFD;                    # *PFM* REQUEST INTERFACE #
        PROC REWIND;                 # INTERFACE TO *REWIND* MACRO #
        PROC RPEJECT;                # STARTS A NEW REPORT PAGE #
        PROC SETPFP;                 # SET PERMANENT FILE PARAMETERS #
        PROC VLAMSF;                 # ANALYZE THE SFM CATALOG #
        PROC VLAPFC;                 # ANALYZE THE *PFC* CATALOG #
        PROC VLBLDVT;                # BUILD VALIDATION TABLE #
        PROC VLERROR;
        PROC VLMSG;                  # ISSUE INFORMATIONAL MESSAGE #
        PROC VLSMSC;                   # #
        PROC VLRCL;                  # RECALL #
        PROC VLREQEX;                # REQUEST TO EXEC #
        PROC VLRPT;                  # VALIDATION REPORT #
        PROC VLSUBHD;                # ISSUE REPORT SUBHEADING #
        PROC WRITEF;                 # INTERFACE TO *WRITEF* MACRO #
        PROC ZFILL;                  # ZERO FILL BLOCK #
        END
 
#
**** PROC VLSUBFM - XREF LIST END.
#
 
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTINGS #
 
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBCMS
*CALL COMBCPR
*CALL COMBMAP
*CALL COMBMCT
*CALL COMBPFP
*CALL COMSPFM
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLM
*CALL COMTVLV
 
 
      ITEM J         I;              # TEMPORARY VARIABLE #
      ITEM FLAG      I;              # STATUS FLAG #
      ITEM I         I;              # INDUCTION VARIABLE #
      ITEM PROCESSED B;              # FLAG TO CONTROL LOOP #
 
                                               CONTROL EJECT;
 
#
*     INITIALIZE CATALOG AREAS.
#
 
      SSINIT;
 
 
#
*     VALIDATE THE "LIVE" SFM CATALOGS IF THE RF PARAMETER
*     WAS NOT SELECTED.
#
 
      IF PAR$RF EQ 0
      THEN
        BEGIN  # GET LIVE CATALOG #
 
#
*     SET FAMILY AND UI IN JOB ATTRIBUTES FOR THE SFM CATALOG FILES.
#
 
        PFP$FAM[0] = PAR$FM;
        PFP$UI[0] = DEF$UI + SBINDX;
        PFP$FG1[0] = TRUE;           # SET FAMILY #
        PFP$FG4[0] = TRUE;           # SET UI #
        SETPFP(PFP);
        IF PFP$STAT[0] NQ 0
        THEN                         # FAMILY NOT FOUND IN SYSTEM #
          BEGIN
          VLERROR(VE"NOFAM",ABRT);   # ISSUE MESSAGE AND ABORT #
          END
 
#
*     ATTACH THE SFM CATALOG FILE FOR SUBFAMILY.
#
 
        VLCT$LFNX[0] = SBINDX + "0";  # APPEND SUBFAMILY TO *LFN* #
        VLPF$NAMEX[0] = SBINDX + "0";  # APPEND SUBFAMILY TO *PFN* #
        PROCESSED = FALSE;
        REPEAT WHILE NOT PROCESSED
        DO
          BEGIN  # ATTACH SFM CATALOG #
          PFD("ATTACH",VLCTLFN,VLPFN,"M","RM","RC",STAT,"NA",0,0);
          IF STAT EQ FBS OR STAT EQ PFA
          THEN                       # FILE IS BUSY #
            BEGIN
            MP$WD[1] = VLPF$NAME[0];
            LFUN = (ATAS*8) + LGET;
            CINTLK(LFUN,PAR$FM,2**SBINDX);  # GET THE INTERLOCK #
            CINTLK(LGET,PAR$FM,2**SBINDX);  # GET THE INTERLOCK #
            VLRCL(WAITPF);           # DELAY AWHILE #
            END
 
          ELSE
            BEGIN
            IF STAT NQ 0
            THEN
              BEGIN
              VLERROR(VE"CATO",ABRT);
              END
 
            ELSE
              BEGIN
              PROCESSED = TRUE;
              END
 
            END
 
          END  # ATTACH SFM CATALOG #
 
        VLMSG(VM"CLEARB");
        END  # GET LIVE CATALOG #
 
      ELSE                           # PAR$RF DOES NOT EQUAL 0 #
 
#
*     OTHERWISE USE THE SFM CATALOG FILE CREATED FROM THE RDF FILE.
#
 
        BEGIN
        VLCT$LFNX[0] = SBINDX+"0";   # APPEND SUBFAMILY TO *LFN* #
        END
 
#
*     OPEN THE SFM CATALOG FOR THE SUBFAMILY.
#
 
      COPEN(PAR$FM,SBINDX,VLCTLFN,"RM",TRUE,STAT);
      LOFPROC(VLCTLFN);              # ADD LFN TO LIST OF FILES #
      IF STAT NQ CMASTAT"NOERR"
      THEN                           # ERROR WHEN OPENING #
        BEGIN
        VLERROR(VE"CATO",ABRT);      # ABORT WITH MESSAGE #
        END
 
 
#
*     PERFORM SUBCATALOG VALIDATION FOR EACH SELECTED *SM* THAT
*         EXISTS.
#
 
      SLOWFOR SMINDX = 1 STEP 1 UNTIL 8
      DO
        BEGIN  # SUBCATALOG VALIDATION #
 
#
*     SKIP IF THE *SM* WAS NOT SELECTED IN THE *SM* PARAMETER.
#
 
        IF B<SMINDX,1>PAR$SM EQ 0
        THEN
          BEGIN
          TEST SMINDX;
          END
 
#
*     BEGIN VALIDATION FOR THE SUBCATALOG.
#
 
        MP$WD[1] = SBINDX + "0";
        MP$WD[2] = SMINDX;
        VLMSG(VM"VALX");             # VALIDATING SB = N SM = X #
 
        SCRPTED = FALSE;             # SUB-CATALOG HEADING FLAG #
        SCDTLH = FALSE;
 
        REWIND(PROBFILE,RCL);        # OPEN PROBLEM FILE #
 
#
*     ATTACH AND OPEN THE SMMAP FILE IF THE AM OPTION WAS SELECTED.
#
 
        IF PAR$AM NQ 0
        THEN
          BEGIN  # GET SMMAP FILE #
          PFP$FAM[0] = DEF$FAM;
          PFP$UI[0] = DEF$UI;
          PFP$FG1[0] = TRUE;         # SET FAMILY #
          PFP$FG4[0] = TRUE;         # SET UI #
          SETPFP(PFP);
 
          VLCM$LFNX[0] = SMINDX;
          PROCESSED = FALSE;
          REPEAT WHILE NOT PROCESSED
          DO
            BEGIN  # SMMAP ACCESS #
              MOPEN(SMINDX,VLCMLFN,"RM",STAT);    # OPEN SMMAP #
            LOFPROC(VLCMLFN);        # ADD LFN TO LIST OF FILES #
            IF STAT EQ CMASTAT"INTLK"
            THEN                     # FILE BUSY #
              BEGIN
              MP$WD[1] = VLCM$LFN[0];
              VLMSG(VM"WAITCAT");    # ISSUE MESSAGE TO B DISPLAY #
              VLREQEX(TYP"TYP3",REQTYP3"REL$MPLK");  # GET INTERLOCK #
              VLRCL(WAITPF);         # DELAY #
              END
 
            ELSE
              BEGIN
              PROCESSED = TRUE;      # OPEN COMPLETED #
              END
 
            END  # SMMAP ACCESS #
 
          IF STAT NQ CMASTAT"NOERR"
          THEN                       # ERROR WHEN OPENING #
            BEGIN
            VLERROR(VE"MAPO",ABRT);  # ABORT WITH MESSAGE #
            END
 
          END  # GET SMMAP FILE #
 
 
#
*     CALCULATE THE MEMORY SIZE REQUIRED FOR THE *VT* TABLE AND
*     ISSUE THE MEMORY REQUEST TO THE SYSTEM.
#
 
      MEM$WDS[0] = MEM$MIN + 2048*MAXGRT + 64;
        IF MEM$WDS[0] GQ MEM$MAX
        THEN                         # MEMORY NOT AVAILABLE #
          BEGIN
          VLERROR(VE"NOFL",ABRT);    # ABORT WITH MESSAGE #
          END
 
        MEMORY("CM",MEMRQST,RCL,NA);  # REQUEST MEMORY #
 
        P<VTTABLE> = MEM$MIN;        # ARRAY BASED AT MEM$MIN #
        ZFILL(VTTABLE,2048 * MAXGRT);
 
        SLOWFOR J = 0 STEP 1 UNTIL MAX$Z
        DO                           # CLEAR VLCMAP ARRAY #
          BEGIN
          VLCM$Z[J] = 0;
          END
 
#
*     ANALYZE EACH GROUP OF SUBFAMILY AND WRITE TO PROBLEM FILE.
#
 
 
        SLOWFOR J = 1 STEP 1             ##
          WHILE J LQ MAXGP               ##
          AND (J-1) LQ (PRM$ENTRC[SMINDX]/16)
        DO                            # PROCESS EACH GROUP #
          BEGIN
          GROUPX = J;
          VLBLDVT(J);                 # BUILD *VT* TABLE #
          VLAMSF;                     # VALIDATE ENTRIES IN *VT* #
          VLAPFC(J);                     # VALIDATE THE *PFC* ENTRIES #
          IF (J EQ MAXGP       ##
            OR J-1 EQ PRM$ENTRC[SMINDX]/16)  ##
            AND PAR$AM NQ 0
          THEN       # LAST CARTRIDGE IN GROUP #
            BEGIN
            VLSMSC;
            END
 
          WRITEF(PROBFILE,RCL);
          VLRPT(J);
          ZFILL(VTTABLE,2048*MAXGRT);
          REWIND(PROBFILE,RCL);
          WRITEF(PROBFILE,RCL);
          REWIND(PROBFILE,RCL);
          END
 
 
 
#
*     CLOSE THE SMMAP FILE IF IT WAS OPENED.
#
 
        IF PAR$AM NQ 0
        THEN
          BEGIN
          MCLOSE(SMINDX,STAT);
          IF STAT NQ CMASTAT"NOERR"
          THEN                       # ERROR IN CLOSING #
            BEGIN
            MP$WD[1] = "VLSUBFM";    # NAME FOR MESSAGE #
            VLERROR(VE"SYSERR",ABRT);  # ABORT WITH MESSAGE #
            END
 
          VLREQEX(TYP"TYP3",REQTYP3"REC$MPLK");  # RETURN INTERLOCK #
          END
 
#
*     ISSUE THE "GOOD" SUBCATALOG HEADING IF NO ERRORS WERE DETECTED.
#
 
        IF NOT SCRPTED
        THEN
          BEGIN
          VLSUBHD(SHTYP"OK");        # SUB-CATALOG HEADING #
          END
 
        END  # SUBCATALOG VALIDATION #
 
#
*     CLOSE THE SFM CATALOG.
#
 
      CCLOSE(PAR$FM,SBINDX,0,STAT);
      IF STAT NQ CMASTAT"NOERR"
      THEN                           # ERROR IN CLOSING #
        BEGIN
        MP$WD[1] = "VLSUBFM";        # NAME FOR MESSAGE #
        VLERROR(VE"SYSERR",ABRT);    # ABORT WITH MESSAGE #
        END
 
#
*     IF USING THE LIVE SFM CATALOG, RELEASE THE LOCK.
#
 
      IF PAR$RF EQ 0
      THEN
        BEGIN
        LFUN = (ATAS*8) + LREL;
        CINTLK(LFUN,PAR$FM,2**SBINDX);  # RELEASE INTERLOCK #
        END
 
 
      END  # VLSUBFM #
 
    TERM
PROC VLSUBHD(RTYP);
# TITLE VLSUBHD - ISSUE REPORT SUBHEADING.                            #
 
      BEGIN  # VLSUBHD #
 
#
**    VLSUBHD - ISSUE SUBCATALOG HEADING.
*
*     *VLSUBHD* FORMATS AND ISSUES THE SUBCATALOG HEADING.
*
*     PROC VLSUBHD(RTYP)
*
*     ENTRY     (RTYP) - HEADING TYPE.
*
*     EXIT      THE SUBCATALOG HEADING IS WRITTEN TO THE
*               REPORT FILE.  THE HEADING WILL BE ONE OF THE FOLLOWING -
*               - "GOOD"
*               - "INTERSECTIONS" AND ITS SUB-HEADING.
*               - "PROBLEMS" AND ITS SUB-HEADING.
*
*     NOTES     SEE *SSVAL* DOCUMENTATION FOR A GENERAL
*               DESCRIPTION OF THE REPORT.
#
 
      ITEM RTYP       I;             # HEADING TYPE #
 
#
****  PROC VLSUBHD - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC RPLINE;                 # CALLS *RPLINEX* TO PRINT A
                                       LINE #
        PROC VLBFILL;                # BLANK FILL #
        PROC VLSUBTD;                # GET SUB-HEADING TIME AND DATE #
        END
 
#
****  PROC VLSUBHD - XREF LIST END.
#
 
      DEF LISTCON #0#;
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLF
 
      ITEM TYP        I;             # HEADING TYPE #
 
#
*     THE FOLLOWING ARRAYS ARE REPORT FILE HEADING LINES.
#
 
      ARRAY SUBHEAD1 [0:0] S(8);     # SUB-HEADING LINE #
        BEGIN
        ITEM SH$D1     C(00,00,80) = ["0   SUBFAMILY = N   SM = X "];
        ITEM SH$SUB     C(01,36,01);
        ITEM SH$SM     C(02,30,01);
        ITEM SH$DESC    C(02,48,14);
        ITEM SH$D2      C(04,24,06) = ["LPDT ="];
        ITEM SH$DATE    C(05,00,10);
        ITEM SH$TIME    C(06,00,10);
        END
 
 
 
      ARRAY RDTL [0:0] S(8);         # PROBLEM HEADING #
        BEGIN
        ITEM RD$DEF     C(00,00,80) = ["       ERR   "];
        ITEM RD$D1      C(01,18,20) = ["IDENTIFICATION"];
        ITEM RD$D2      C(03,30,12) = ["  -CHAIN- "];
        ITEM RD$D3      C(05,06,20) = ["ERROR DESCRIPTION"];
        END
 
      ARRAY RDTL2 [0:0] S(8);        # PROBLEM HEADING 2 #
        BEGIN
        ITEM RD$DD1     C(00,00,80) = ["       TYP"];
        ITEM RD$DD2     C(03,18,20) = ["FCT - AU - A/U - H/E"];
        END
 
      ARRAY ICHDR [0:0] S(5);        # INTERSECTION HEADING #
        BEGIN
        ITEM ICH$DEF    C(00,00,50) = [" "];
        ITEM ICH$D1     C(02,36,20) = ["- HEAD OF CHAINS -"];
        END
 
      ARRAY ICDTL [0:0] S(5);        # INTERSECTION HEADING 2 #
        BEGIN
        ITEM ICD$DEF    C(00,00,50) = [" "];
        ITEM ICD$D1     C(02,12,11) = ["FCTORD - AU"];
        ITEM ICD$D2     C(03,42,11) = ["FCTORD - AU"];
        END
 
                                               CONTROL EJECT;
 
      TYP = RTYP;                    # SET HEADING TYPE #
 
#
*     GET THE LAST PURGED DATE/TIME FOR THE SUBCATALOG.
#
 
      VLSUBTD(SCPDATE,SCPTIME);
      SH$DATE[0] = SCPDATE;          # SUBCATALOG DATE #
      SH$TIME[0] = SCPTIME;          # SUBCATALOG TIME #
 
#
*     BUILD THE VARIABLE FIELDS OF THE REPORT HEADING.
#
 
      SH$SUB[0] = SBINDX + "0";
      SH$SM[0] = SMINDX;
 
#
*     FILL IN THE REPORT DESCRIPTION DEPENDING ON THE REQUESTED
*     HEADING TYPE.
#
 
      IF TYP EQ SHTYP"OK"
      THEN
        BEGIN
        SH$DESC[0] = "  -- GOOD -- ";
        END
 
      IF TYP EQ SHTYP"ICT"
      THEN
        BEGIN
        SH$DESC[0] = "INTERSECTIONS";
        END
 
      IF TYP EQ SHTYP"PRPT"
      THEN
        BEGIN
        SH$DESC[0] = "   PROBLEMS ";
        END
 
#
*     ISSUE THE SUBCATALOG HEADING TO THE REPORT FILE.
#
 
      RPLINE(RPTFADR," ",0,1,EOPL);  # BLANK LINE #
      RPLINE(RPTFADR,SUBHEAD1,0,80,EOPL);
 
#
*     ISSUE THE INTERSECTING CHAIN SUBHEADING IF REQUESTED.
#
 
      IF TYP EQ SHTYP"ICT"
      THEN
        BEGIN
        RPLINE(RPTFADR,ICHDR,0,50,EOPL);
        RPLINE(RPTFADR,ICDTL,0,50,EOPL);
        END
 
#
*     ISSUE THE PROBLEM REPORT SUBHEADING IF REQUESTED.
#
 
      IF TYP EQ SHTYP"PRPT"
      THEN
        BEGIN
        RPLINE(RPTFADR,RDTL,0,80,EOPL);
        RPLINE(RPTFADR,RDTL2,0,80,EOPL);
        END
 
      END  # VLSUBHD #
 
    TERM
PROC VLSUBTD;
# TITLE VLSUBTD - GET SUB-HEADING TIME AND DATE.                      #
 
      BEGIN  # VLSUBTD #
 
#
**    VLSUBTD - GET SUBCATALOG HEADING TIME AND DATE.
*
*     THE LAST PURGED TIME AND DATE FOR THE SUBCATALOG
*     IN THE SUBFAMILY IS RETRIEVED AND EDITED.
*
*     PROC VLSUBTD
*
*     ENTRY     (SMINDX) - *SM* INDEX.
*               (PAR$FM)  - FAMILY PARAMETER.
*               (PAR$RF)  - *RDF* FILE PARAMETER.
*               (SBINDX)  - SUBFAMILY INDEX.
*
*     EXIT      (SCPDATE) - EDITED DATE OR "****".
*               (SCPTIME) - EDITED TIME OR "****".
*
*     NOTES     IF THE SFM CATALOG FROM THE *RDF* FILE IS BEING
*               PROCESSED THE DATE AND TIME IS RETRIEVED BY A *CALLSS*
*               TO *EXEC*.
*
*               IF THE LIVE *MSF* CATALOG IS BEING PROCESSED, THE DATE
*               AND TIME IS RETRIEVED BY THE CATALOG ACCESS ROUTINE
*               *CGETPD*.
*
*               IF THE SUBCATALOG DATE AND TIME IS NOT AVAILABLE
*               OR NOT DEFINED, A FILLER "****" IS PLACED IN THE
*               FIELDS TO BE RETURNED.
#
 
#
****  PROC VLSUBTD - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CGETPD;                 # GET PURGE DATE #
        FUNC EDATE C(10);            # EDIT DATE FROM PACKED FORMAT #
        FUNC ETIME C(10);            # EDIT TIME FROM PACKED FORMAT #
        PROC VLLPDT;                 # GET LAST PURGE DATE AND TIME #
        END
 
#
****  PROC VLSUBTD - XREF LIST END.
#
 
      DEF LISTCON #0#;
*CALL COMBFAS
*CALL COMTVLD
 
      ITEM PDATE      I;             # DATE/TIME FOR SUBCATALOG #
      ITEM QRADDR     I;             # TEMPORARY #
 
                                               CONTROL EJECT;
 
      PDATE = 0;
 
#
*     IF THE LIVE CATALOG IS ATTACHED AND OPENED, GET THE
*     SUBCATALOG DATE/TIME FROM THE CATALOG ACCESS ROUTINE.
#
 
      IF PAR$RF EQ 0
      THEN
        BEGIN
        CGETPD(PAR$FM,SBINDX,SMINDX,PDATE,QRADDR,STAT);
        END
 
#
*     OTHERWISE, GET THE SUBCATALOG DATE/TIME FROM THE LIVE
*     CATALOG VIA A REQUEST TO THE *EXEC*.
#
 
      ELSE
        BEGIN
        VLLPDT(SBINDX,SMINDX,PDATE);
        END
 
      IF PDATE EQ 0
      THEN                           # NO DATE/TIME DEFINED OR
                                       AVAILABLE #
        BEGIN
        SCPDATE = " ******** ";      # FILL DATE SPACE #
        SCPTIME = " ******** ";      # FILL TIME SPACE #
        END
 
      ELSE                           # SUBCATALOG LAST PURGED DATE/TIME
                                     #
        BEGIN
        SCPDATE = EDATE(B<24,18>PDATE);  # EDITED DATE #
        SCPTIME = ETIME(B<42,18>PDATE);  # EDITED TIME #
        END
 
      END  # VLSUBTD #
 
    TERM
PROC VLTITLE;
# TITLE VLTITLE - ISSUE REPORT TITLE.                                 #
 
      BEGIN  # VLTITLE #
 
#
**    VLTITLE - ISSUE REPORT TITLES.
*
*     *VLTITLE* ISSUES THE REPORT FILE TITLE LINE AND, IF THE
*     FAMILY NAME IS DEFINED, ISSUES THE SUB-TITLE LINE.
*
*     PROC VLTITLE
*
*     ENTRY     (PAR$FM) - FAMILY.
#
 
#
****  PROC VLTITLE - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC RPLINEX;                # PRINTS A REPORT LINE #
        PROC VLBFILL;                # BLANK FILL #
        PROC VLSUBHD;                # ISSUE REPORT SUBHEADING #
        END
 
#
****  PROC VLTITLE - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMDECK LISTINGS #
 
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLF
 
 
#
*     TITLE LINES FOR THE REPORT FILE.
#
 
      ARRAY RHDR [0:0] S(8);         # TITLE LINE #
        BEGIN
        ITEM RH$LINE    C(00,00,80) = ["0"];
        ITEM RH$ID      C(00,24,08) = ["SSVAL - "];
        ITEM RH$DESC    C(01,12,40) = ["VALIDATION REPORT"];
        ITEM RH$ID2     C(05,36,08) = ["SSVAL - "];
        ITEM RH$VER     C(06,24,07) = [VLVER];
        END
 
      ARRAY RSUBHD [0:0] S(8);       # SUB-TITLE LINE #
        BEGIN
        ITEM RS$LINE    C(00,00,80) = ["            FAMILY ="];
        ITEM RS$FAM     C(02,06,07);
        END
                                               CONTROL EJECT;
 
      RPLINEX(RPTFADR,RHDR,0,80,EOPL);  # ISSUE TITLE LINE #
 
#
*     ISSUE THE SUB-TITLE LINE IF THE FAMILY PARAMETER IS DEFINED.
#
 
      IF PAR$FM NQ 0
      THEN
        BEGIN
        RS$FAM[0] = PAR$FM;
        VLBFILL(RSUBHD,8);
        RPLINEX(RPTFADR,RSUBHD,0,80,EOPL);  # ISSUE SUB-TITLE LINE #
        END
 
      RPLINEX(RPTFADR,"0",0,1,EOPL);  # 2 BLANK LINES #
 
      RETURN;
      END  # VLTITLE #
 
    TERM
PROC VLWFIX(TYP);
# TITLE VLWFIX - WRITE FIX FILE RECORD.                               #
 
 
      BEGIN  # VLWFIX #
 
#
**    VLWFIX - WRITE A FIXIT FILE RECORD.
*
*     WRITE A FIXIT FILE RECORD.  FOR SOME RECORD TYPES, THE
*     RECORD DATA IS IN THE *EXTRECORD* ARRAY.  FOR OTHER RECORD
*     TYPES, THE RECORD IS BUILT/MODIFIED USING THE ENTRY
*     FIELDS SPECIFIED.
*
*     PROC VLWFIX(TYP)
*
*     ENTRY     (TYP)             - FIXIT FILE RECORD TYPE.
*               (SMINDX)         - *SM* (OPTIONAL).
*               (SBINDX)          - SUBFAMILY (OPTIONAL).
*               (VTPTR)           - INDEX TO CURRENT *VT* ENTRY
*                                   (OPTIONAL).
*               (ARRAY EXTRECORD) - CURRENT PROBLEM FILE RECORD
*                                   (OPTIONAL).
*               (ARRAY FIXIT)     - FIXIT FILE *FET*.
*               (ARRAY VTENTRY)   - CURRENT *VT* ENTRY (OPTIONAL).
*
*     EXIT      A RECORD IS WRITTEN TO THE FIXIT FILE.
#
 
      ITEM TYP        I;             # FIXIT FILE RECORD TYPE #
 
 
#
****  PROC VLWFIX - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC WRITEW;                 # INTERFACE TO *WRITEW* MACRO #
        END
 
#
****  PROC VLWFIX - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMDECK LISTINGS #
*CALL COMBFAS
*CALL COMTVLD
*CALL COMTVLF
*CALL COMTVLV
 
                                               CONTROL EJECT;
 
#
*     BUILD AND WRITE THE FIXIT FILE RECORD.  IN MOST CASES
*     THE PROBLEM RECORD IN THE EXTRECORD ARRAY BECOMES THE
*     FIXIT RECORD.  BUT FOR SOME RECORD TYPES, ADDITIONAL
*     FIELDS ARE ADDED OR THE WHOLE RECORD IS BUILT.
#
 
      FIX$RT[0] = TYP;               # RECORD TYPE #
 
      IF TYP EQ REC"OTHR"
      THEN                           # ADD THE *VT* ENTRY #
        BEGIN
        FIX$VT[0] = VT$ITEM[VTPTR];
        END
 
      IF TYP EQ REC"BADORPH"         ##
        OR TYP EQ REC"FRAG"          ##
        OR TYP EQ REC"BADHOLE"       ##
        OR TYP EQ REC"TFORPH"
      THEN                           # BUILD THE FIXIT RECORD #
        BEGIN
        EXTR$SM[0] = SMINDX;
        EXTR$SB[0] = SBINDX;
        P<VTLINK> = LOC(VTPTR);      # TO EXTRACT *FCT* AND AU #
        EXTR$GPT[0] = VTL$GRT[0];
        EXTR$AU[0] = VTL$AU[0];
        FIX$VT[0] = VT$ITEM[VTPTR];
        EXTR$GP[0] = GROUPX;
        EXTR$FCT[0] = EXTR$GP[0] * 16 + EXTR$GPT[0];
        END
 
      WRITEW(FIXITFILE,EXTRECORD,RLFIX,STAT);
 
      END  # VLWFIX #
 
    TERM
PROC VLWPROB(TYP);
# TITLE VLWPROB - WRITE PROBLEM FILE RECORD.                          #
 
 
      BEGIN  # VLWPROB #
 
#
**    VLWPROB - WRITE THE PROBLEM FILE RECORD.
*
*     WRITE A PROBLEM FILE RECORD.  FOR SOME RECORD TYPES, THE
*     RECORD'S DATA IS IN THE *EXTRECORD* ARRAY.  FOR OTHER TYPES, THE
*     RECORD IS BUILT / MODIFIED USING THE ENTRY FIELDS SPECIFIED.
*
*     PROC VLWPROB(TYP)
*
*     ENTRY     (TYP)             - RECORD TYPE.
*               (SMINDX)         - *SM* (OPTIONAL).
*               (FCTORD)          - *FCT* ORDINAL (OPTIONAL).
*               (SBINDX)          - SUBFAMILY (OPTIONAL).
*               (CSN)             - *CSN* (OPTIONAL).
*               (Y)               - Y ORDINAL (OPTIONAL).
*               (Z)               - Z ORDINAL (OPTIONAL).
 
*               (ARRAY SMMAP)    - SMMAP ENTRY (OPTIONAL).
*               (ARRAY EXTRECORD) - CURRENT EXTRACT FILE RECORD
*               (ARRAY PROBFILE)  - PROBLEM FILE *FET*.
*
*     EXIT      A RECORD IS WRITTEN TO THE PROBLEM FILE.
*
#
 
      ITEM TYP        I;             # PROBLEM RECORD TYPE #
 
#
****  PROC VLWPROB - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC VLERROR;                # ISSUE ERROR MESSAGE #
        PROC WRITEW;                 # INTERFACE TO *WRITEW* MACRO #
        END
 
#
****  PROC VLWPROB - XREF LIST END.
#
 
      DEF LISTCON #0#;               # TURN OFF COMMON DECK LISTING #
 
*CALL COMBFAS
*CALL COMBMAP
*CALL COMTVLD
*CALL COMTVLF
 
                                               CONTROL EJECT;
 
#
*     BUILD THE RECORD FOR THE PROBLEM FILE.  IN MOST CASES THE
*     EXTRACT FILE RECORD IN THE EXTRECORD ARRAY BECOMES THE
*     PROBLEM FILE RECORD.  BUT FOR SOME TYPES, THE WHOLE
*     RECORD MUST BE BUILT.
#
 
      PROB$RT[0] = TYP;              # RECORD TYPE #
 
      IF TYP EQ REC"FCT" OR TYP EQ REC"SM"
      THEN                           # BUILD A PROBLEM FILE RECORD #
        BEGIN
        PROB$Y[0] = Y;
        PROB$Z[0] = Z;
        PROB$CSN[0] = CSN;
        EXTR$FCT[0] = FCTORD;
        EXTR$SB[0] = SBINDX;
        EXTR$SM[0] = SMINDX;
        PROB$SM0[0] = CM$WRD1[0];
        PROB$SM1[0] = CM$WRD2[0];
        PROB$SM2[0] = CM$WRD3[0];
        END
 
 
      WRITEW(PROBFILE,EXTRECORD,RLPROB,STAT);
 
      END  # VLWPROB #
 
    TERM