Retro1.org codex

          IDENT  ACPD
          SST
          ENTRY  ACPD
          ENTRY  PAP
          ENTRY  RFL=
          SYSCOM B1
          TITLE  ACPD - ANALYZE PERFORMANCE DATA.
*COMMENT  ACPD - ANALYZE PERFORMANCE DATA.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
          SPACE  4,10
**        MPAR - MULTIPLE PRECISION ARRAY.
*
* NAME    MPAR   LEN,PREC,LMP
*
*         ENTRY  *NAME*   = NAME OF DATA ITEM.
*                *LEN*    = NUMBER OF ENTRIES OF DATA ITEM.
*                *PREC*   = PRECISION OF ITEM IN PP WORDS.
*                *LMP*    = POINTER TO LENGTH MULTIPLIER.
*
*         EXIT   *NAME*   = ORDINAL OF ITEM IN THE CORRESPONDING TABLE.
*                *P.NAME* = PRECISION OF THE ITEM.
*                *L.NAME* = LENGTH OF THE ITEM.
*
*         NOTE   *MPAR* TABLE FORMAT IS
*T        24/NAME,3/TP,6/LMP,4/ICM,11/PREC,12/LEN
*
*         WHERE
*
*         *TP*   TYPE OF BLOCK (HEADER, FAST, MEDIUM, SLOW
*                OR SNAPSHOT LOOP).
*         *ICM*  INDICATES THAT THE FOLLOWING GROUP OF DATA ELEMENTS
*                (UP TO THE NEXT DEFINITION OF *ICM*) IS EITHER A
*                SINGLE OR MULTIPLE ELEMENT ENTRY.
*
*         WARNING - IF ARRAY LENGTH IS NOT EQUAL TO ONE. THE ELEMENT
*         PRECISION MUST NOT BE GREATER THAN TWO.
 
          PURGMAC MPAR
 
          MACRO  MPAR,NAME,LEN,PREC,LMP
          NOREF  .IC,.TYPE,BL
 .1       IFC    EQ,$NAME$$
          CON    0
 .1       ELSE
 .2       IFC    EQ,$PREC$$
          ERR                PRECISION NOT SPECIFIED
 .2       ENDIF
          IFNE   LEN,1,1
          ERRNG  2-P.NAME    OFFSET CALCULATION ERROR
          IFEQ   BL,0,1
 .IC      SET    0
 NAME     EQU    .IC
 .IC      SET    .IC+1
 P.NAME   EQU    PREC 0
 L.NAME   EQU    LEN 0
          VFD    24/4L_NAME,3/.TYPE,6/LMP,4/.ICM,11/P.NAME,12/L.NAME
 BL       SET    BL+P.NAME*L.NAME
 .1       ENDIF
          ENDM
          SPACE  4,10
**        DDSC - DATA DESCRIPTION.
*
* NAME    DDSC   SDL,DTY,WFA,WFP
*
*         ENTRY  *NAME* = ORDINAL OF ITEM IN THE CORRESPONDING
*                         *MPAR* TABLE.
*                *SDL*  = SELECTION BIT.
*                *DTY*  = DATA TYPE OF ITEM.
*                *WFA*  = WEIGHT FACTOR INSTRUCTION.
*                *WFP*  = WEIGHT FACTOR POINTER.
*
*         EXIT   *DDSC* ENTRY CONTAINS A POINTER TO THE DECODED
*                DATA BUFFER *DBUF*, WHERE THE DATA OF THE ITEM
*                IS DECODED AND STORED.
*
*         NOTE - *DDSC* ENTRY FORMAT IS
*
*T        1/S,3/D,3/WI,13/WFP,4/ICM,18/LEN,18/FW
*
*         WHERE
*
*         *S*    IS *SDL*.
*         *D*    IS *DTY*.
*         *WI*   IS *WFA*.
*         *ICM*  SINGLE/MULTIPLE ELEMENT ENTRY INDICATOR.
*         *LEN*  LENGTH OF THE DATA ELEMENT.
*         *FW*   POINT TO THE DECODED DATA BUFFER WHERE
*                THE VALUE OF THE DATA ELEMENT IS STORED.
*
*         WARNING - THE *MPAR* TABLE HAS TO BE DEFINED BEFORE
*         *DDSC* TABLE CAN BE DEFINED. THE RELATIVE POSITION
*         OF THE DATA ITEMS IN *DDSC* TABLE MUST BE THE SAME
*         AS IN *MPAR* TABLE.
 
          PURGMAC DDSC
 
          MACRO  DDSC,NAME,SDL,DTY,WFA,WFP
          NOREF  .L,.FW,L._NAME,P._NAME
          IFGT   P._NAME,5
 .L       SET    P._NAME/5*L._NAME
          ELSE
 .L       SET    L._NAME
          ENDIF
          VFD    1/SDL,3/DTY,3/WFA,13/WFP,4/0,18/.L,18/.FW
 .FW      SET    .FW+.L
          ENDM
          SPACE  4,10
**        DSPT - DISPLAY TEXT DEFINITION.
*
* NAME    DSPT   MSGE,SBTL,WORD,BITA,BITL
*
*         ENTRY  *NAME* = ORDINAL OF ITEM IN THE CORRRESPONDING
*                         *DDSC* TABLE.
*                *MSGE* = DISPLAY TEXT.
*                *SBTL* = POINTER TO SUBBLOCK TITLES.
*                *WORD* = WORD COUNT IN MULTITPLE-WORD ENTRY.
*                *BITA* = BEGIN BIT POSITION FOR NON-WORD-BOUNDARY
*                         ITEMS.
*                *BITL* = BIT LENGTH.
*
*         EXIT   *DSPT* BUILDS *DSPTENT* TABLE AND *DSPTTXT* TABLE.
*                THE *DSPTTXT* TABLE CONTAINS TEXTS USED IN THE REPORT.
*                THE *DSPTENT* ENTRY FORMAT IS
*
*T               9/NAME,6/WORD,6/BITA,6/BITL,9/SBTL,6/LN,18/BC
*
*                WHERE *LN* IS THE LENGTH IN CHARACTER OF THE TEXT,
*                AND *BC* IS THE BEGIN CHARACTER POSITION OF THE
*                TEXT IN *DSPTTXT* TABLE.
 
 M2       MICRO  1,,**
 .BC      SET    0
 
          PURGMAC DSPT
 
          MACRO  DSPT,NAME,MSGE,SBTL,WORD,BITA,BITL
          NOREF  .EC,.LN,.L,.BC,SBT
          NOREF  .WC,.CC,.RC,.I
          IFC    EQ,$SBTL$$
 SBT      SET   777B
          ELSE
 SBT      SET   SBTL
          ENDIF
 M1       MICRO  1,,MSGE
 .EC      SET    .EC+1
 .LN      MICCNT M1
 M        MICRO  1,,*"M2""M1"*
 .L       MICCNT M
          USE    /DSPTENT/
          VFD    9/NAME,6/WORD,6/BITA,6/BITL,9/SBT,6/.LN,18/.BC
 .BC      SET    .BC+.LN
          USE
          USE    /DSPTTXT/
          IFNE   .LN,0
 .WC      SET    .L/10
 .CC      SET    .WC*10
 .RC      SET    .L-.CC
 M2       MICRO  .CC+1,.RC,*"M"*
 .I       SET    1
          DUP    .WC
 MSG      MICRO  .I,10,*"M"*
          DATA   10H"MSG"
 .I       SET    .I+10
          ENDD
          ELSE
          DATA   10H"M2"
          ENDIF
          USE
          ENDM
          SPACE  4,10
**        SMGT - SUBBLOCK REPORT TITLE DEFINITION.
*
*         SMGT   MSGE,CNT,STC
*
*         ENTRY  *MSGE* = SUBBLOCK REPORT TITLE.
*                *CNT*  = NUMBER OF ENTRIES IN THE SUBBLOCK.
*                *STC*  = STARTING NUMBER. IGNORED IF *CNT* IS OMITTED.
*
*         EXIT   *SMGT* BUILDS A TABLE OF DISPLAY TEXT,
*                TEN CHARACTERS, LEFT JUSTIFIED, BLANK FILLED
*                FOR EACH ENTRY.
 
          PURGMAC SMGT
 
 SMGT     MACRO  MSGE,CNT,STC
          NOREF  .ST,.SM
 MM       MICRO  1,,MSGE
 .IF      IFC    NE,$CNT$$
 .ST      SET    STC
          DUP    CNT
 .IF1     IFLT   .ST,10B
 MC       OCTMIC .ST,1
 .IF1     ELSE
 MC       OCTMIC .ST,2
 .IF1     ENDIF
 MG       MICRO  1,,$"MM""MC"$
 .ST      SET    .ST+1
          DATA   10H"MG"
 .SM      SET    .SM+1
          ENDD
 .IF      ELSE
          DATA   10H"MM"
 .SM      SET    .SM+1
 .IF      ENDIF
          ENDM
          SPACE  4,10
**        DEF - DEFINE CONSTANT.
*
*         DEF   NAM#VAL#;
*
*         ENTRY  *NAM* = CONSTANT NAME.
*                *VAL* = CONSTANT VALUE.
*
*         EXIT   *DEF* DEFINES SYMBOLIC CONSTANTS USED BY BOTH
*                SYMPL AND COMPASS PROGRAMS.
*
*         WARNING - *DEF* CAN ONLY BE USED TO DEFINE INTEGER CONSTANTS.
*         NON-INTEGER CONSTANTS HAVE TO BE CONVERTED TO INTEGER BEFORE
*         *DEF* CAN BE USED.
 
          PURGMAC DEF
 
 DEF     MACRO  VALUE
          NOREF  .BB
 .NAM     MICRO  1,,#_VALUE
 .BB      MICCNT .NAM
 .BB      SET    .BB+2
 .VAL     MICRO  .BB,,;_VALUE
 .VAL     MICRO  1,,#".VAL"
 ".NAM" EQU ".VAL"
 DEF      ENDM
          SPACE  4,10
**        COMMON DECKS.
 
*CALL     COMCMAC
*CALL     COMSPRD
*CALL     COMSCPS
*CALL     COMSEJT
*CALL     COMSSSD
*CALL     COMSSCD
          LIST   X
*CALL     COMSCPD
*CALL     COMUCPD
          LIST   *
          TITLE
ACPD      SPACE  4,10
***       ACPD - ANALYZE PERFORMANCE DATA.
*
*         THIS ENTRY POINT IS NEEDED IN ORDER FOR THE
*         ABSOLUTE BINARY RECORD NAME TO MATCH WITH THE
*         DECK NAME *ACPD*. IT CONTAINS ONLY A JUMP
*         INSTRUCTION TO TRANSFER TO THE MAIN SYMPL
*         PROGRAM *ACPDM*.
 
 
 ACPD     BSS    0           TRANSFER ADDRESS FROM THE LOADER
          EQ     =XACPDM     TO SYMPL MAIN PROGRAM
          TITLE  PAP - PROCESS ACPD PARAMETERS.
*         *PAP* DATA DEFINITIONS.
          SPACE  4,10
 DS       DATA   0LSUMMARY   SECONDARY DEFAULT VALUE OF S
 DN       DATA   0L9999999   SECONDARY DEFAULT VALUE OF N
 
 
 TARG     BSS    0
 FN       ARG    FN,FN       INPUT FILE
 L        ARG    L,L         REPORT FILE
 S        ARG    DS,S,400B   SUMMARY FILE
 LO       ARG    LO,LO       LIST OPTION
 IN       ARG    IN,IN,400B  INTERVAL LENGTH IN MINUTES
 IC       ARG    IC,IC,400B  INTERVAL RECORD COUNT
 N        ARG    DN,N,400B   NUMBER OF FILES
 BT       ARG    BT,BT       BEGINNING TIME
 ET       ARG    ET,ET       ENDING TIME
 BD       ARG    BD,BD       BEGINNING DATE
 ED       ARG    ED,ED       ENDING DATE
          ARG
 
 ERC      CON    0           ERROR CODE
 ERF      CON    FATAL       FATAL ERROR
 EFL      CON    0           ERROR NAME
 
 PAR      BSS    0           PERROR PARAMETER LIST
          VFD    60/ERC
          VFD    60/ERF
          VFD    60/EFL
 
 VARG     BSS    0
          DATA   0LFN
          DATA   0LL
          DATA   0LS
          DATA   0LLO
          DATA   0LIN
          DATA   0LIC
          DATA   0LN
          DATA   0LBT
          DATA   0LET
          DATA   0LBD
          DATA   0LED
PAP       EJECT
**        PAP - PROCESS *ACPD* PARAMETERS.
*
*         *PAP* VALIDATES *ACPD* PARAMETERS, AND CONVERTS
*         PARAMETERS IN DISPLAY CODE NUMBER TO BINARY.
 
 PAP      SUBR               ENTRY/EXIT
          SB1    1
          SA1    ACTR
          SA4    ARGR
          SB4    X1          NUMBER OF ARGUMENTS
          SB5    TARG
          RJ     ARG
          NZ     X1,PAP12    IF ERROR
          SA5    FN
          ZR     X5,PAP11    IF NO DATA FILE
          SA5    LO
          LX5    6
          SX4    X5-1RZ
          ZR     X4,PAP1     IF *Z* OPTION
          NZ     X5,PAP11    IF INCORRECT OPTION
 PAP1     SA5    N           CONVERT *N* PARAMETER
          SB7    B1+         ASSUME DECIMAL CONVERSION
          RJ     DXB
          NZ     X4,PAP11    IF ERROR
          ZR     X6,PAP11    IF ZERO VALUE ENTERED
          SA6    A5+         SET *N* VALUE
          SA1    IN
          SA5    IC
          ZR     X5,PAP2     IF *IC* NOT SPECIFIED
          ZR     X1,PAP2     IF *IN* NOT SPECIFIED
          SX6    ERM14       * IN AND IC PARAMETER CONFLICT.*
          EQ     PAP13       PROCESS ERROR
 
 PAP2     NZ     X5,PAP3     IF *IC* SPECIFIED
          SA5    IN
          SX6    6
          ZR     X5,PAP4     IF *IN* NOT SPECIFIED
 PAP3     RJ     DXB
          NZ     X4,PAP11    IF ARGUMENT ERROR
          ZR     X6,PAP11    IF ARGUMENT ERROR
 PAP4     SA6    A5          SET *IN* OR *IC* VALUE
 
*         CHECK FOR *BT* AND *ET* PARAMETERS.
 
          SB2    B1+B1
          MX0    8*6
          SA5    BT-1
 
 PAP7     SA5    A5+B1
          ZR     X5,PAP8     IF PARAMETER NOT SPECIFIED OR ZERO
          LX5    2*6
          BX2    -X0*X5
          SB3    X2-2R24
          GE     B3,PAP11    IF HOUR .GE. 24
          SB3    X2-2R00
          NG     B3,PAP11    IF HOUR .LT. 00
          LX5    2*6
          BX2    -X0*X5
          SB3    X2-2R60
          GE     B3,PAP11    IF MINUTE .GE. 60
          SB3    X2-2R00
          NG     B3,PAP11    IF MINUTE .LT. 00
          MX4    -6
          LX5    6
          BX2    -X4*X5
          SB3    X2-1R6
          GE     B3,PAP11    IF SECOND .GE. 6X
          SB3    X2-1R0
          NG     B3,PAP11    IF SECOND .LT. 0X
          LX5    6
          BX2    -X4*X5
          SB3    X2-1R9
          LX5    2*6
          GT     B3,PAP11    IF SECOND .GT. X9
          SB3    X2-1R0
          NG     B3,PAP11    IF SECOND .LT. X0
          LX5    2*6
          BX2    -X0*X5
          NZ     X2,PAP11    IF TIME TOO LONG
 PAP8     SB2    B2-B1
          GT     B2,PAP7     IF NOT DONE
 
*         CHECK FOR *BD* AND *ED* PARAMETERS.
 
          SB2    2
          SA5    BD-1
 
 PAP9     SA5    A5+B1
          ZR     X5,PAP10    IF PARAMETER NOT SPECIFIED OR ZERO
          LX5    2*6
          BX2    -X0*X5
          SB3    X2-2R99
          GT     B3,PAP11    IF YEAR .GT. 99
          SB3    X2-2R70
          PL     B3,PAP9.1   IF YEAR .GE. 70
          SB3    X2-2R33
          GT     B3,PAP11    IF YEAR .GT. 33
          SB3    X2-2R00
          NG     B3,PAP11    IF YEAR .LT. 00
 PAP9.1   LX5    2*6
          BX2    -X0*X5
          SB3    X2-2R12
          GT     B3,PAP11    IF MONTH .GT. 12
          SB3    X2-2R01
          NG     B3,PAP11    IF MONTH .LT. 01
          LX5    2*6
          BX2    -X0*X5
          SB3    X2-2R31
          GT     B3,PAP11    IF DAY .GT. 31
          SB3    X2-2R01
          NG     B3,PAP11    IF DAY .LT. 01
          MX3    -6
          BX4    -X3*X2
          SB3    X4-1R9
          GT     B3,PAP11    IF DATE .GT. X9
          SB3    X4-1R0
          NG     B3,PAP11    IF DATE .LT. X0
          LX5    2*6
          BX2    -X0*X5
          NZ     X2,PAP11    IF DATE TOO LONG
 PAP10    SB2    B2-B1
          GT     B2,PAP9     IF NOT DONE
          EQ     PAPX        RETURN
 
*         PROCESS ARGUMENT ERROR.
 
 PAP11    SB2    FN          GET ARGUMENT NAME
          SB2    A5-B2
          SA4    B2+VARG
 
 PAP12    MX0    2*6
          BX6    X0*X4
          SA6    EFL
          SX6    ERM1        * ACPD ARGUMENT ERROR - XX.*
 
*         PROCESS ERROR.
 
 PAP13    SA6    ERC         SET ERROR CODE
          SA1    PAR         SET PARAMETER ADDRESS
          RJ     =XPERROR    NO RETURN
          SPACE  4,10
*         COMMON DECKS
 
*CALL     COMCARG
*CALL     COMCDXB
 
          END    ACPD
*WEOR
PRGM ACPDM;
# TITLE ACPDM - ANALYZE PERFORMANCE DATA.  #
 
      BEGIN  # ACPDM #
 
#
***   ACPDM - ANALYZE PERFORMANCE DATA.
*
*     ANALYZE PERFORMANCE DATA COLLECTED BY *CPD*.
*
*     COMMAND FORMAT.
*
*     ACPD(P1,P2,...,PN)
*
*     WHERE PI IS ANY OF THE FOLLOWING.
*
*     OPTION       DEFAULT       DESCRIPTION
*
*     FN=LFN1      SAMPLE        DATA FILE NAME.
*     L=LFN2       OUTPUT        REPORT FILE NAME.
*     S=LFN3       0             SUMMARY FILE NAME.
*                                IF NO EQUIVALENCE, *S* IS ASSUMED
*                                TO BE *SUMMARY*.
*     IN=NNN       6 MINS        INTERVAL LENGTH IN MINUTES.
*                                IF THE IC PARAMETER IS SPECIFIED AND
*                                IN IS NOT, THE IC VALUE IS USED
*                                INSTEAD OF THE IN PARAMETER DEFAULT
*                                TO SPECIFY THE REPORT INTERVAL.  USE
*                                OF BOTH THE IN AND IC PARAMETERS
*                                RESULTS IN AN ERROR.
*     IC=NNN       0 RECORDS     INTERVAL RECORD COUNT.  SPECIFIES THE
*                                NUMBER OF SAMPLE FILE RECORDS PER
*                                REPORT INTERVAL.  USE OF BOTH THE IN
*                                AND IC PARAMETERS RESULTS IN AN ERROR.
*     N=NNN        1 FILE        NUMBER OF FILES TO PROCESS.
*                                IF NO EQUIVALENCE, *ACPD* WILL PROCESS
*                                UNTIL EOI OF *LFN1* IS REACHED.
*     LO=Z         0             LIST OPTION. IF LO=Z, ELEMENTS
*                                WITH ZERO VALUES WILL BE PRINTED.
*                                IF LO=0 (DEFAULT), THESE ELEMENTS
*                                WILL NOT BE PRINTED. *Z* IS THE
*                                ONLY VALID OPTION.
*     BT=HHMMSS    0             BEGINNING TIME. IF *BT* IS OMITTED,
*                                PROCESSING WILL BEGIN AT THE
*                                CURRENT DATA FILE POSITION. IF *BT*
*                                IS SPECIFIED, PROCESSING WILL
*                                BEGIN AT THE FILE CONTAINING THE
*                                RECORD WHOSE TIME EQUALS TO *BT*.
*     BD=YYMMDD    0             BEGINNING DATE. IF *BD* IS OMITTED,
*                                *BD* WILL BE ASSUMED THE DATE OF THE
*                                FILE WHERE THE DATA FILE IS
*                                CURRENTLY POSITIONED.
*     ET=HHMMSS    0             ENDING TIME. *ACPD* WILL TERMINATE
*                                WHEN THE RECORD WHOSE TIME EQUALS
*                                TO *ET* IS REACHED.
*     ED=YYMMDD    0             ENDING DATE. *ED* AND *ET* FORM THE
*                                ENDING TIME. IF *ED* IS SPECIFIED BUT
*                                *ET* IS OMITTED, THE ENDING TIME IS
*                                ZERO HOUR OF DAY *ED*. IF *ED* IS
*                                OMITTED BUT *ET* IS SPECIFIED, *ED*
*                                IS SET TO THE VALUE OF *BD*. IF BOTH
*                                *ED* AND *ET* ARE OMITTED, *ACPD* WILL
*                                TERMINATE IF THE FOLLOWING OCCURS :
*                                -NUMBER OF FILES SPECIFIED IN THE
*                                 *N* PARAMETER ARE PROCESSED.
*                                -AT EOI OF THE DATA FILE.
*
*     SUMMARY FILE FORMAT.
*
*     THE SUMMARY FILE HAS TWO TYPES OF RECORD, THE HEADER BLOCK
*     RECORD AND THE DATA BLOCK RECORD.
*     THE HEADER BLOCK RECORD IS THE HEADER RECORD OF THE DATA
*     FILE IN THE UNPACKED FORMAT.
*     EACH DATA BLOCK RECORD CONTAINS VALUES OF THE DATA BLOCK
*     ELEMENTS IN ONE REPORT INTERVAL.
*     THE DATA BLOCK RECORD HAS TWO EQUAL LENGTH PARTS. THE
*     FIRST PART CONTAINS THE AVERAGE VALUES OF THE DATA BLOCK
*     ELEMENTS. THE SECOND PART CONTAINS THE STANDARD DEVIATIONS
*     OF EACH DATA BLOCK ELEMENTS.
*     THE LOOP SAMPLE TIMES AND THE SNAPSHOT ELEMENTS DO NOT
*     HAVE STANDARD DEVIATIONS (0).
*     THERE IS AN EOR BETWEEN TWO CONSECUTIVE RECORDS.
*
*     MESSAGES.
*
*        -ACPD ARGUMENT ERROR - XX.
*           ERROR DETECTED IN COMMAND SYNTAX.
*
*        -BT/BD NOT FOUND.
*           *BT*/*BD* GREATER THAN THE TIME OF THE LAST DATA RECORD.
*
*        -CPD/ACPD VERSIONS MISMATCH.
*           *CPD* AND *ACPD* VERSIONS ARE NOT COMPATIBLE.
*
*        -DATA BLOCKS MISSING.
*           EXPECTED DATA BLOCKS FOLLOWING HEADER BLOCK NOT FOUND.
*
*        -DATA ELEMENT NAME UNDEFINED - XXXX.
*           DATA ELEMENT XXXX IS NOT DEFINED IN COMMON DECK COMSCPD.
*
*        -DATA FILE POSITIONED AT *EOI*.
*           DATA FILE IS INITIALLY POSITIONED AT EOI.
*
*        -DATA FILE EMPTY.
*           DATA FILE IS EMPTY.
*
*        -DATA FILE CONTENT ERROR.
*           DATA FILE GENERATED BY *CPD* IS NOT IN THE EXPECTED
*           FORMAT.
*
*        -DATA FILE NOT AT BEGINNING OF A FILE.
*           AT THE BEGINNING OF PROCESSING, THE DATA FILE IS
*           POSITIONED EITHER AT THE MIDDLE OF A RECORD, OR
*           AT THE BEGINNING OF A DATA BLOCK RECORD.
*
*        -DATA FILE NOT FOUND - XXX.
*           DATA FILE XXX IS NOT LOCAL TO THE JOB AT THE TIME *ACPD*
*           IS RUNNING.
*
*        -DATA FILE NOT IN CHRONOLOGICAL ORDER.
*           DATA FILE IS NOT IN THE INCREASING ORDER OF TIME OF THE
*           RECORDS.
*
*        -IN LESS THAN FILE WRITE TIME.
*           REPORT TIME INTERVAL LESS THAN FILE WRITE TIME
*           (*FW*) OF *CPD*.
*
*        -IN AND IC PARAMETER CONFLICT.
*           THE IN AND IC PARAMETERS WERE BOTH SPECIFIED ON THE *ACPD*
*           COMMAND.
*
*        -N EXCEEDS NUMBER OF FILES.
*           NUMBER OF FILES REQUESTED GREATER THAN NUMBER OF FILES
*           ON THE DATA FILE.
*
*
*     NOTE.
*
*     TO BUILD *ACPD*, DO THE FOLLOWING :
*
*         - MODIFY(Z)/*EDIT,ACPD
*         - COMPASS(I,S=NOSTEXT)
*         - SYMPL(I)
*         - LDSET(LIB=SRVLIB,PRESET=ZERO)
*         - LOAD(LGO)
*         - NOGO(ACPD,ACPD,$RFL=$)
*
#
 
#
****  PRGM ACPDM - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC DATBLK;                 # PROCESS DATA BLOCK #
        PROC HEADER;                 # PROCESS HEADER BLOCK #
        PROC INITLZ;                 # INITIALIZE *ACPD* #
        PROC MESSAGE;                # ISSUE DAYFILE MESSAGE #
        PROC RPCLOSE;                # CLOSE FILES #
        END
 
#
****  PRGM ACPDM - XREF LIST END.
#
 
      DEF LISTCON    #0#;            #TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM DTDC       B;             # DATA BLOCK DECODED FLAG #
      ITEM HDDC       B;             # HEADER BLOCK DECODED FLAG #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM LSTM       U;             # TIME OF LAST RECORD #
      ITEM EDTM       B;             # ENDING TIME EXPIRED FLAG #
 
 
 
 
 
#
*     BEGIN *ACPDM* PROGRAM.
#
 
      INITLZ(HDDC,DTDC,EDTM);        # INITIALIZE *ACPD* #
 
      SLOWFOR I=1 STEP 1 WHILE (I LQ P$N) AND (NOT EDTM)
      DO
        BEGIN  # PROCESS ONE FILE #
        HEADER(EDTM,HDDC,LSTM);      # PROCESS HEADER BLOCK #
        IF (NOT EDTM)                # NOT EOI #
        THEN
          BEGIN
          DATBLK(EDTM,DTDC,LSTM);    # PROCESS DATA BLOCK #
          END
 
        END  # PROCESS ONE FILE #
 
      IF (P$L NQ NULL)               # REPORT FILE SPECIFIED #
      THEN
        BEGIN  # CLOSE REPORT FILE #
        RPCLOSE(OFFA);
        END
 
      MESSAGE(" ACPD COMPLETE.",3);
      END  # ACPDM #
      TERM
PROC ACMSTA((STA),(FWA),(DTY),(BCL),(WFP));
# TITLE ACMSTA - PRINT TOTAL STATISTICAL VALUES.  #
 
      BEGIN  # ACMSTA #
 
#
**    ACMSTA - PRINT TOTAL STATISTICAL VALUES.
*
*     PRINT PERCENTAGE, STANDARD DEVIATION, AND AVERAGE
*     OF ONE DATA ELEMENT FOR THE ENTIRE *ACPD* RUN.
*
*     PROC ACMSTA((STA),(FWA),(DTY),(BCL),(WFP))
*
*     ENTRY      STA = STATISTICAL VALUE TO BE COMPUTED.
*                FWA = ADDRESS OF THE DATA ELEMENT IN TABLE *DDSM*.
*                DTY = DATA TYPE.
*                BCL = BEGINNING COLUMN TO PRINT THE VALUE.
*                WFP = WEIGHT FACTOR.
*
*     EXIT       THE AVERAGE, STANDARD DEVIATION, AND PERCENTAGE
*                OF THE DATA ELEMENT FOR THE ENTIRE RUN ARE PRINTED.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM STA        U;             # STATISTIC TO BE COMPUTED #
      ITEM FWA        U;             # DATA ELEMENT ORDINAL #
      ITEM DTY        U;             # DATA TYPE #
      ITEM BCL        U;             # BEGINNING COLUMN #
      ITEM WFP        R;             # WEIGHT FACTOR #
 
#
****  PROC ACMSTA - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        FUNC SQRT R;                 # SQUARE ROOT FUNCTION #
        PROC WRITEV;                 # WRITE DATA ELEMENT #
        END
 
#
****  PROC ACMSTA - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM VL         R;             # TEMPORARY STORAGE #
 
      ARRAY MAXVAL [0:0] P(1);       # MAXIMUM VALUE #
        BEGIN  # ARRAY MAXVAL #
        ITEM MAXR       R(00,00,60);  # REAL VALUE #
        ITEM MAXI       I(00,00,60);  # INTEGER VALUE #
        END  # ARRAY MAXVAL #
 
      ARRAY MINVAL [0:0] P(1);       # MINIMUM VALUE #
        BEGIN  # ARRAY MINVAL #
        ITEM MINR       R(00,00,60);  # REAL VALUE #
        ITEM MINI       I(00,00,60);  # INTEGER VALUE #
        END  # ARRAY MINVAL #
 
      ARRAY TOTVAL [0:0] P(1);       # TOTAL REPORT VALUE #
        BEGIN  # ARRAY TOTVAL #
        ITEM TOTR       R(00,00,60);  # REAL VALUE #
        ITEM TOTI       I(00,00,60);  # INTEGER VALUE #
        END  # ARRAY TOTVAL #
 
      SWITCH STAT:STVAL              # STATISTIC #
             PCSS:PCST,              # PERCENTAGE #
             SDSS:SDST,              # STANDARD DEVIATION #
             AVSS:AVST;              # AVERAGE #
 
      LABEL PRSTAT;                  # PRINT TOTAL STATISTICS #
 
 
 
 
#
*     BEGIN ACMSTA PROC.
#
 
      P<DDSM>=LOC(DBUF[DCHL + DCDC*DCDL*2]);
      GOTO STAT[STA];
 
#
*     COMPUTE AND PRINT TOTAL PERCENTAGE.
#
 
PCSS:                                # PERCENTAGE #
      IF (WFP EQ 0)
      THEN
        BEGIN
        TOTR[0]=0.0;
        END
 
      ELSE
        BEGIN
        TOTR[0]=(DDSM$SM[FWA]/(ACNS*WFP))*100.0;
        END
 
      MAXR[0]=DDSM$PX[FWA];          # MAXIMUM PERCENTAGE #
      MINR[0]=DDSM$PN[FWA];          # MINIMUM PERCENTAGE #
      GOTO PRSTAT;
 
#
*     COMPUTE AND PRINT TOTAL STANDARD DEVIATION.
#
 
SDSS:                                # STANDARD DEVIATION #
      VL=DDSM$SM[FWA]/ACNS;
      TOTR[0]=SQRT(DDSM$SQ[FWA]/ACNS - VL*VL);
      MAXR[0]=DDSM$SX[FWA];          # MAXIMUM STANDARD DEVIATION #
      MINR[0]=DDSM$SN[FWA];          # MINIMUM STANDARD DEVIATION #
      GOTO PRSTAT;
 
#
*     COMPUTE AND PRINT TOTAL AVERAGE.
#
 
AVSS:                                # AVERAGE #
      VL=DDSM$SM[FWA];
      IF (DTY EQ FLPC)               # REAL FORMAT #
      THEN
        BEGIN
        TOTR[0]=VL/ACNS;
        MAXR[0]=DDSM$AX[FWA];        # MAXIMUM AVERAGE #
        MINR[0]=DDSM$AN[FWA];        # MINIMUM AVERAGE #
        END
 
      ELSE                           # NOT REAL FORMAT #
        BEGIN
        TOTI[0]=VL/ACNS;
        MAXI[0]=DDSM$AX[FWA];        # MAXIMUM AVERAGE #
        MINI[0]=DDSM$AN[FWA];        # MINIMUM AVERAGE #
        END
 
#
*     PRINT TOTAL STATISTICS.
#
 
PRSTAT:                              # PRINT STATISTIC VALUES #
      WRITEV(TOTVAL[0],DTY,BCL+1,9,NLFC);
      WRITEV(MAXVAL[0],DTY,BCL+10,10,NLFC);
      WRITEV(MINVAL[0],DTY,BCL+20,10,LFDC);
      RETURN;
      END  # ACMSTA #
 
      TERM
PROC ADJUST;
# TITLE ADJUST - ADJUST TABLES AND FIELD LENGTH.  #
 
      BEGIN  # ADJUST #
 
#
**    ADJUST - ADJUST TABLES AND FIELD LENGTH.
*
*     THIS PROC RECOMPUTES THE FIELD LENGTH AND BUFFER ADDRESSES.
*     IT ALSO COMPUTES THE DECODED BUFFER ADDRESSES OF TABLES
*     *DDHD* AND *DDDT*.
*     THE MASS STORAGE DEVICE SUBBLOCK TITLE TABLE IS CONSTRUCTED
*     BASED ON THE EST.
*
*     PROC ADJUST
*
*     ENTRY      NONE.
*
*     EXIT       THE NEW DECODED BUFFER LENGTHS OF THE HEADER
*                BLOCK *DCHL* AND DATA BLOCK *DCDL* ARE COMPUTED.
*                THE DECODED BUFFER POINTERS OF TABLES *DDHD* AND
*                *DDDT* ARE COMPUTED.
*                NEW FIELD LENGTH IS COMPUTED.
*                MASS STORAGE DEVICE SUBBLOCK TITLE TABLE IS
*                CONSTRUCTED.
#
 
#
****  PROC ADJUST - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC MEMORY;                 # REQUEST MEMORY #
        FUNC XCOD C(10);             # NUMBER TO DISPLAY OCTAL #
        END
 
#
****  PROC ADJUST - XREF LIST END.
#
 
      DEF BLKC       #" "#;          # BLANK #
      DEF CPWC       #5#;            # NUMBER OF CHARACTER PER WORD #
      DEF MXVC       #1.0E20#;       # MAXIMUM VALUE #
      DEF NA         #"NA"#;         # NO ABORT FLAG #
      DEF RECALL     #1#;            # RECALL FLAG #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
*CALL     COMUEST
 
#
*     LOCAL VARIABLES.
#
 
      ITEM BL         I;             # BUFFER LENGTH #
      ITEM BLC        I;             # BUFFER LENGTH #
      ITEM CBL        I;             # CURRENT BUFFER LENGTH #
      ITEM CM         C(10)="CM";    # MEMORY ARGUMENT #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM IC         I;             # INCREMENTOR #
      ITEM J          I;             # FOR LOOP CONTROL #
      ITEM L          I;             # TEMPORARY STORAGE #
      ITEM LN         I;             # LENGTH #
      ITEM M          I;             # TEMPORARY STORAGE #
      ITEM MSI        I;             # *MST* ORDINAL #
      ITEM N          I;             # TEMPORARY STORAGE #
      ITEM ORD        C(10);         # *MST* ORDINAL DISPLAY #
      ITEM PR         I;             # PRECISION #
      ITEM RBL        I;             # REQUESTED BUFFER LENGTH #
      ITEM RDCDL      I;             # REQUESTED BUFFER LENGTH #
      ITEM RDCHL      I;             # REQUESTED BUFFER LENGTH #
 
      BASED
      ARRAY MSD [0:0] P(1);          # MASS STORAGE DEVICE #
        BEGIN  # ARRAY MSD #
        ITEM MSD$WD     I(00,00,60);  # MSD ENTRY #
        ITEM MSD$EQ     C(00,00,03);  # EQUIPMENT NAME #
        ITEM MSD$OR     C(00,18,07);  # EQUIPMENT ORDINAL #
        END  # ARRAY MSD #
 
      ARRAY STT [0:0] P(1);          # MEMORY ARGUMENT #
        BEGIN  # ARRAY STT #
        ITEM STT$RFL    U(00,00,30);  # REQUESTED FIELD LENGTH #
        ITEM STT$CMB    U(00,59,01);  # COMPLETION BIT #
        END  # ARRAY STT #
 
 
 
 
 
 
#
*     BEGIN ADJUST PROC.
#
 
      P<DCHD>=LOC(DBUF);
 
#
*     COMPUTE LENGTH OF THE HEADER BLOCK DECODED BUFFER.
#
 
      BL=0;
      P<MPAR>=LOC(HDTR);
      P<DDSC>=LOC(DDHD);
 
      J=0;
      SLOWFOR M=0 WHILE (MPAR$WD[J] NQ 0)
      DO
        BEGIN  # COMPUTE HEADER BLOCK LENGTH AND BUFFER ADDRESS #
        LN=MPAR$LN[J];
        IF (MPAR$LMP[J] NQ 0)
        THEN
          BEGIN
          LN=LN*DCHD$WD[DDSC$FW[MPAR$LMP[J]]];
          END
 
        PR=MPAR$PR[J];
        IF (PR GR CPWC)
        THEN
          BEGIN
          LN=(PR/CPWC)*LN;
          END
 
        BLC=BL;
        IC=MPAR$IC[J];
        FASTFOR I=1 STEP 1 UNTIL IC
        DO
          BEGIN
          DDSC$FW[J]=BLC;
          DDSC$LN[J]=LN;
          DDSC$IC[J]=IC;
          BL=BL+LN;
          BLC=BLC+1;
          J=J+1;
          END
 
        END  # COMPUTE HEADER BLOCK LENGTH AND BUFFER ADDRESS #
 
      RDCHL=BL+1;                    # NEW HEADER BLOCK BUFFER LENGTH #
 
#
*     COMPUTE THE DATA BLOCK DECODED BUFFER LENGTH.
#
 
      BL=0;
      J=0;
      P<MPAR>=LOC(DATT);
 
      SLOWFOR M=0 WHILE (MPAR$WD[J] NQ 0)
      DO
        BEGIN  # COMPUTE DATA BLOCK LENGTH AND BUFFER ADDRESS #
        P<DDSC>=LOC(DDHD);
        LN=MPAR$LN[J];
        IF (MPAR$LMP[J] NQ 0)
        THEN
          BEGIN
          LN=LN*DCHD$WD[DDSC$FW[MPAR$LMP[J]]];
          END
 
        PR=MPAR$PR[J];
        IF (PR GR CPWC)
        THEN
          BEGIN
          LN=(PR/CPWC)*LN;
          END
 
        P<DDSC>=LOC(DDDT);
        BLC=BL;
        IC=MPAR$IC[J];
        FASTFOR I=1 STEP 1 UNTIL IC
        DO
          BEGIN
          DDSC$FW[J]=BLC;
          DDSC$LN[J]=LN;
          DDSC$IC[J]=IC;
          BL=BL+LN;
          BLC=BLC+1;
          J=J+1;
          END
 
        END  # COMPUTE DATA BLOCK LENGTH AND BUFFER ADDRESS #
 
      RDCDL=BL+1;                    # NEW DATA BLOCK LENGTH #
 
#
*     COMPUTE NEW FIELD LENGTH.
#
 
      RBL=RDCHL+(RDCDL*DCDC*2)+(RDCDL*8);  # NEW LENGTH #
      CBL=DCHL+(DCDL*DCDC*2)+(DCDL*8);  # OLD LENGTH #
      HGAD=HGAD + (RBL-CBL);         # UPDATE HIGHEST ADDRESS #
      DCHL=RDCHL;
      DCDL=RDCDL;
      IF (HGAD GR CRFL)              # EXCEED FIELD LENGTH #
      THEN
        BEGIN
        STT$RFL[0]=HGAD;
        MEMORY(CM,STT,RECALL,NA);    # REQUEST MEMORY #
        CRFL=STT$RFL[0];             # UPDATE CURRENT FIELD LENGTH #
        END
 
#
*     INITIALIZE DECODED BUFFER AND TOTAL BUFFER.
#
 
      P<DCDT>=LOC(DBUF[DCHL]);
      P<DDSM>=LOC(DBUF[DCHL + DCDC*DCDL*2]);
      FASTFOR I=0 STEP 1 UNTIL DCDC*DCDL*2 - 1
      DO
        BEGIN
        DCDT$WD[I]=0;
        END
 
      FASTFOR I=0 STEP 1 UNTIL DCDL-1
      DO
        BEGIN
        DDSM$IM[I]=0;
        DDSM$IQ[I]=0;
        DDSM$AX[I]=0;
        DDSM$AN[I]=MXVC;
        DDSM$SX[I]=0;
        DDSM$SN[I]=MXVC;
        DDSM$PX[I]=0;
        DDSM$PN[I]=MXVC;
        END
 
#
*     CONSTRUCT THE MASS STORAGE DEVICE SUBBLOCK TITLE TABLE.
#
 
      P<DDSC>=LOC(DDHD);
      P<EST>=LOC(DCHD$WD[DDSC$FW[ESTB]]);
      P<MSD>=LOC(SMGT[EQTN]);
      MSI=0;
 
      SLOWFOR J=0 STEP 1 UNTIL DCHD$WD[DDSC$FW[ESTL]] - 1
      DO
        BEGIN  # SEARCH FOR MASS STORAGE DEVICE IN EST #
        IF (EST$MS[J])               # MASS STORAGE DEVICE #
        THEN
          BEGIN  # BUILD SUBBLOCK TITLE #
          MSD$EQ[MSI]="EQ ";
          MSD$OR[MSI]=BLKC;
          ORD=XCOD(J);               # CONVERT TO DISPLAY #
          N=0;
 
          SLOWFOR I=9 STEP -1 WHILE (C<I,1>ORD NQ BLKC)
          DO                         # COUNT NUMBER OF DIGITS #
            BEGIN
            N=N+1;
            END
 
          M=I+1;
          L=0;
 
          SLOWFOR I=1 STEP 1 WHILE (I LQ N)
          DO                         # BUILD MST ORDINAL #
            BEGIN
            C<L,1>MSD$OR[MSI]=C<M,1>ORD;
            L=L+1;
            M=M+1;
            END
 
          MSI=MSI+1;
          END  # BUILD SUBBLOCK TITLE #
 
        END  # SEARCH FOR MASS STORAGE DEVICE IN EST #
 
      MSD$WD[MSI]=0;                 # END OF TABLE #
 
      RETURN;
      END  # ADJUST #
 
      TERM
PROC CHKSPA((SPC),WFT,PRFLG);
# TITLE CHKSPA - CHECK SPECIAL ACTION.  #
 
      BEGIN  # CHKSPA #
 
#
**    CHKSPA - CHECK SPECIAL ACTION.
*
*     *CHKSPA* PERFORMS TASKS THAT CANNOT BE TABLE DRIVEN.
*     CURRENTLY THESE ACTIONS INCLUDE COMPUTING AVAILABLE
*     MEMORY AND BUFFERED I/O CHECKING.
*
*     PROC CHKSPA((SPC),WFT,PRFLG)
*
*     ENTRY      SPC   = SPECIAL ACTION CODE.
*
*     EXIT       WFT   = WEIGHT FACTOR.
*                PRFLG = FLAG INDICATES IF ELEMENT IS TO BE PROCESSED.
#
 
#
*     PARAMETER LIST.
#
      ITEM SPC        I;             # SPECIAL ACTION CODE #
      ITEM WFT        R;             # WEIGHT FACTOR #
      ITEM PRFLG      B;             # PROCESS FLAG #
 
#
****  PROC CHKSPA - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC WRITEV;                 # WRITE DATA VALUE #
        END
 
#
****  PROC CHKSPA - XREF LIST END.
#
 
      DEF NPCC       #-1.0#;         # NO PERCENTAGE FLAG #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM TEM        I;             # TEMPORARY STORAGE #
 
      SWITCH SPAT
             AVMS,                   # AVAILABLE MEMORY #
             BIOS,                   # BUFFERED I/O #
             ;                       # END OF SPAT #
 
 
 
 
 
 
#
*     BEGIN CHKSPA PROC.
#
 
      P<DCHD>=LOC(DBUF);
      P<DDSC>=LOC(DDHD);
      PRFLG=FALSE;
 
      GOTO SPAT[SPC];
 
AVMS:                                # AVAILABLE MEMORY #
 
      WFT=DCHD$WD[DDSC$FW[MEMS]]-DCHD$WD[DDSC$FW[CMRS]];
      PRFLG=TRUE;
      RETURN;
 
BIOS:                                # BUFFERED I/O PARAMETERS #
      WFT=DCHD$WD[DDSC$FW[TIOB]];
      IF (WFT NQ 0)                  # SYSTEM HAS BUFFERED I/O #
      THEN
        BEGIN
        PRFLG=TRUE;
        END
 
      RETURN;
 
#
*     END CASE.
#
 
      END  # CHKSPA #
 
      TERM
PROC COMPWF((WFA),(WFP),(POS),WFT,PRFLG);
# TITLE COMPWF - COMPUTE WEIGHT FACTOR.  #
 
      BEGIN  # COMPWF #
 
#
**    COMPWF - COMPUTE WEIGHT FACTOR.
*
*     COMPUTE WEIGHT FACTOR FOR PERCENTAGE CALCULATION.
*
*     PROC COMPWF((WFA),(WFP),(POS),WFT,PRFLG)
*
*     ENTRY      WFA = WEIGHT FACTOR INFORMATION.
*                WFP = WEIGHT FACTOR.
*                POS = RELATIVE POSITION OF THE WEIGHT FACTOR.
*
*     EXIT       WFT = COMPUTED WEIGHT FACTOR.
*                      WFT=-1.0 IF PERCENTAGE NOT TO BE PRINTED.
*                PRFLG = PROCESS FLAG.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM WFA        U;             # WEIGHT FACTOR INFORMATION #
      ITEM WFP        U;             # WEIGHT FACTOR #
      ITEM POS        I;             # RELATIVE POSITION OF *WFP* #
      ITEM WFT        R;             # COMPUTED WEIGHT FACTOR #
      ITEM PRFLG      B;             # PROCESS FLAG #
 
#
****  PROC COMPWF - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CHKSPA;                 # CHECK SPECIAL ACTION #
        END
 
#
****  PROC COMPWF - XREF LIST END.
#
 
      DEF NPCC       #-1.0#;         # NO PERCENTAGE FLAG #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
 
      SWITCH WFAT
             WGFS,                   # WEIGHT FACTOR SPECIFIED #
             NWFS,                   # NO WEIGHT FACTOR #
             CWFS,                   # CONSTANT WEIGHT FACTOR #
             SPAS,                   # SPECIAL ACTION #
             IWFS,                   # INDIRECT WEIGHT FACTOR #
             ;                       # END OF WFAT #
 
 
 
 
 
#
*     BEGIN COMPWF PROC.
#
 
      P<DCHD>=LOC(DBUF);
      P<DDSC>=LOC(DDHD);
      PRFLG=TRUE;
      GOTO WFAT[WFA];
 
WGFS:                                # WEIGHT FACTOR SPECIFIED #
      WFT=DCHD$WD[DDSC$FW[WFP] + POS];
      RETURN;
 
NWFS:                                # NO WEIGHT FACTOR #
      WFT=NPCC;
      RETURN;
 
CWFS:                                # CONSTANT WEIGHT FACTOR #
      WFT=WFP;
      IF (WFP EQ 100)                # CONSTANT FACTOR IS 100 #
      THEN                           # NO PERCENTAGE #
        BEGIN
        WFT=NPCC;
        END
 
      RETURN;
 
SPAS:                                # SPECIAL ACTION #
 
      CHKSPA(WFP,WFT,PRFLG);
      RETURN;
 
IWFS:                                # INDIRECT WEIGHT FACTOR #
      WFT=0.0;                       # TO BE COMPUTED #
      RETURN;
 
#
*     END CASE.
#
 
      END  # COMPWF #
 
      TERM
PROC DATBLK(EDTM,DTDC,LSTM);
# TITLE DATBLK - PROCESS DATA BLOCK.  #
 
      BEGIN  # DATBLK #
 
#
**    DATBLK - PROCESS DATA BLOCK.
*
*     DATBLK PROCESSES DATA BLOCKS OF EACH FILE IN THE DATA FILE.
*
*     PROC DATBLK(EDTM,DTDC,LSTM)
*
*     ENTRY      EDTM = TRUE IF ENDING TIME REACHED,
*                       FALSE IF OTHERWISE.
*                DTDC = INDICATE IF DATA BLOCK HAS BEEN DECODED.
*                FILE IS POSITIONED AT THE FIRST DATA BLOCK RECORD.
*
*     EXIT       TIME = TRUE IF ENDING TIME REACHED.
*                LSTM = TIME OF LAST RECORD.
*                DATA FILE IS POSITIONED AT EITHER *EOI* OR
*                AT *EOF* OF THE CURRENT FILE. IF TIME IS TRUE,
*                DATA FILE IS AT THE RECORD CONTAINING THE
*                ENDING TIME.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM EDTM       B;             # ENDING TIME OR EOI FLAG #
      ITEM DTDC       B;             # DECODE DATA BLOCK FLAG #
      ITEM LSTM       U;             # TIME IF LAST RECORD #
 
#
****  PROC DATBLK - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC DECODE;                 # DECODE *CIO* INPUT BUFFER DATA #
        FUNC DTMNUM U;               # CONVERT DATE/TIME TO BINARY #
        PROC PERROR;                 # PROCESS ERROR #
        PROC PUTDAT;                 # PRINT DATA BLOCK ELEMENTS #
        PROC READRC;                 # READ ONE RECORD FROM DATA FILE #
        PROC WRTSUM;                 # WRITE SUMMARY FILE #
        END
 
#
****  PROC DATBLK - XREF LIST END.
#
 
      DEF DOTC       #TRUE#;         # FLAG #
      DEF MXVC       #1.0E10#;       # MAXIMUM VALUE #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM BC         I;             # BEGINNING COLUMN #
      ITEM FW         I;             # FILE WRITE TIME #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM J          I;             # FOR LOOP CONTROL #
      ITEM K          I;             # FOR LOOP CONTROL #
      ITEM NS         I;             # SAMPLING FREQUENCY #
      ITEM PT         I;             # ADDRESS OF DECODED DATA BLOCK #
      ITEM STAT       I;             # I/O STATUS #
      ITEM TM         I;             # TIME OF CURRENT RECORD #
 
 
 
 
 
#
*     BEGIN DATBLK PROC.
#
 
      P<DCHD>=LOC(DBUF);
      P<DCDT>=LOC(DBUF[DCHL]);
      P<DDSM>=LOC(DBUF[DCHL + DCDC*DCDL*2]);
      TLFG=1;                        # SUBTITLE IS TO BE PRINTED #
 
#
*     DETERMINE REPORT INTERVAL LENGTH.
#
 
      P<DDSC>=LOC(DDHD);
      FW=DCHD$WD[DDSC$FW[DLFW]];     # FILE WRITE TIME #
      IF (P$IN NQ 0)                 # INTERVAL TIME SPECIFIED #
      THEN
        BEGIN
        NS=(P$IN*60)/FW;             # NUMBER OF RECORDS PER INTERVAL #
        IF (NS EQ 0)                 # *IN* .LT. *FW* #
        THEN
          BEGIN
          PERROR(ERM10,FATAL,NULL);  # IN LESS THAN FILE WRITE TIME #
          END
 
        END
 
      ELSE
        BEGIN
        NS=P$IC;                     # NUMBER OF RECORDS PER INTERVAL #
        END
 
      IF (DTDC)                      # FIRST DATA BLOCK DECODED #
      THEN
        BEGIN
        BC=2;                        # COLLECT NEXT SAMPLE #
        ACNS=1;
        TM=P$BT;
        DTDC=FALSE;
        END
 
      ELSE                           # NOT DECODED #
        BEGIN
        BC=1;                        # COLLECT FIRST SAMPLE #
        ACNS=0;
        TM=DTMNUM(DCHD$WD[DDSC$FW[DATE]],DOTC,TRUE)*SHFC;
        TM=TM + DTMNUM(DCHD$WD[DDSC$FW[TIME]],DOTC,FALSE);
        END
 
#
*     PROCESS DATA BLOCKS UNTIL EITHER END OF
*     CURRENT FILE OR END TIME IS REACHED.
#
 
      PT=LOC(DCDT);
      P<DDSC>=LOC(DDDT);
      STAT=EORC;
      TCOL=0;                        # TOTAL NUMBER OF COLUMNS #
 
      SLOWFOR K=1 STEP 1 WHILE (STAT EQ EORC) AND (P$ET GR TM)
      DO
        BEGIN  # COLLECT DATA #
 
#
*     COLLECT DATA FOR 10 COLUMNS AND PUT THEM IN THE DECODED
*     DATA BLOCK BUFFER *DCDT*. *PT* IS THE ADDRESS OF WHERE THE
*     DECODED DATA ARE TO BE STORED IN *DCDT*. FOR EACH COLUMN, THE
*     NUMBER OF DATA BLOCKS NEEDED TO COLLECT IS DETERMINED BY *NS*.
#
 
        SLOWFOR I=1 STEP 1 UNTIL DCDC
        DO
          BEGIN  # PROCESS 10 COLUMNS #
          SLOWFOR J=BC STEP 1 UNTIL NS
          DO
            BEGIN  # COLLECT DATA FOR THE I-TH COLUMN #
            IF (IBWA GQ IBNW)        # INPUT BUFFER EXHAUSTED #
            THEN
              BEGIN  # GET NEXT RECORD #
              READRC(STAT);          # READ NEXT RECORD #
              IF (STAT NQ EORC)      # EOF OR EOI #
              THEN
                BEGIN
                TEST K;              # END OF CURRENT FILE #
                END
 
              IBWA=0;                # RESET INPUT BUFFER POINTER #
              END  # GET NEXT RECORD #
 
            DECODE(LOC(DATT),PT);    # DECODE DATA BLOCK #
            ACNS=ACNS+1;             # NUMBER OF DATA BLOCKS DECODED #
            TM=DCDT$WD[(I-1)*DCDL + DDSC$FW[PDTM]];  # GET TIME #
            IF (TM GQ P$ET)          # CURRENT TIME GREATER THAN #
            THEN                     # ENDING TIME #
              BEGIN
              TEST K;                # ENDING TIME REACHED #
              END
 
            END  # COLLECT DATA FOR THE I-TH COLUMN #
 
          BC=1;
          TCOL=TCOL+1;
          PT=PT+DCDL;                # NEXT BUFFER ADDRESS #
          END  # PROCESS 10 COLUMNS #
 
#
*     DATA OF THE FAST, MEDIUM, SLOW, AND SNAPSHOT LOOPS FOR 10
*     COLUMNS HAVE BEEN DECODED AND SAVED IN DECODED DATA BLOCK
*     BUFFER *DCDT*. NOW PRINT THE DATA TO THE REPORT FILE AND
*     THE SUMMARY FILE IF THE SUMMARY FILE IS SPECIFIED.
#
 
        PUTDAT(NS,DCDC);             # COMPUTE DATA BLOCK ELEMENTS #
        IF (P$S NQ NULL)             # SUMMARY FILE SPECIFIED #
        THEN
          BEGIN
          WRTSUM(DCDC);              # WRITE SUMMARY FILE #
          END
 
#
*     REINITIALIZE THE DECODED DATA BLOCK BUFFER FOR NEXT
*     COLLECTION OF DATA.
#
 
        PT=LOC(DCDT);
        SLOWFOR I=0 STEP 1 UNTIL DCDC*DCDL*2 - 1
        DO
          BEGIN
          DCDT$WD[I]=0;
          END
 
        END  # COLLECT DATA #
 
#
*     PROCESS END CASE.
*     THE NUMBER OF COLUMNS MAY NOT BE 10, AND THE NUMBER OF DATA
*     BLOCKS COLLECTED FOR THE LAST COLUMN MAY NOT BE *NS*.
#
 
      IF (STAT NQ EORC)              # EOF OR EOI #
      THEN
        BEGIN
        J=J-1;
        END
 
#
*     IF LAST COLUMN DOES NOT HAVE ENOUGH BLOCKS, IGNORE LAST
*     COLUMN.
#
 
      IF (J LS NS)                   # NOT ENOUGH BLOCKS #
      THEN
        BEGIN  # IGNORE LAST INCOMPLETED COLUMN #
        I=I-1;
        IF (I EQ 0)                  # ONLY ONE COLUMN COLLECTED #
        THEN
          BEGIN
          I=1;
          NS=J;
          END
 
        END  # IGNORE LAST INCOMPLETED COLUMN #
 
      IF (NS GR 0)                   # LAST COLUMN HAS DATA #
      THEN
        BEGIN
        PUTDAT(NS,I);                # PROCESS LAST COLLECTION #
        IF (P$S NQ NULL)             # SUMMARY FILE SPECIFIED #
        THEN                         # WRITE SUMMARY FILE #
          BEGIN
          WRTSUM(I);
          END
 
        END
 
      IF (I GR (DCDC-3))             # MORE THAN 7 COLUMNS COLLECTED #
        OR (NS EQ 0)                 # NO BLOCK WAS COLLECTED #
      THEN                           # PRINT TOTAL ON NEXT PAGE #
        BEGIN
        PUTDAT(NS,0);                # PRINT TOTAL #
        END
 
#
*     THE CURRENT FILE IS DONE. CHECK IF THERE IS ANOTHER FILE
*     TO REPORT.
#
 
      IF (P$ET LQ TM)                # ENDING TIME REACHED #
        OR (STAT EQ EOIC)            # EOI ENCOUNTERED ON FILE #
      THEN
        BEGIN
        EDTM=TRUE;                   # ENDING TIME REACHED OR EOI #
        END
 
      ELSE                           # DONE WITH THE CURRENT FILE #
        BEGIN
        LSTM=TM;                     # TIME OF LAST RECORD #
        END
 
      RETURN;
      END  # DATBLK #
 
      TERM
PROC DATELM(FLG,MS1,MS2,(WFA),(WFP),(POS),(DTY),(FWA),(NSF));
# TITLE DATELM - PROCESS ONE DATA BLOCK ELEMENT.  #
 
      BEGIN  # DATELM #
 
#
**    DATELM - PROCESS ONE DATA BLOCK ELEMENT.
*
*     COMPUTE AND PRINT ONE DATA BLOCK ELEMENT-S STATISTICAL
*     VALUES (AVERAGE, STANDARD DEVIATION, AND PERCENTAGE).
*
*     PROC DATELM(FLG,MS1,MS2,(WFA),(WFP),(POS),(DTY),(FWA),(NSF))
*
*     ENTRY      FLG = TRUE IF SUB BLOCK TITLE IS TO BE PRINTED.
*                MS1 = SUB BLOCK TITLE.
*                MS2 = DATA ELEMENT NAME.
*                WFA = WEIGHT FACTOR INFORMATION.
*                WFP = WEIGHT FACTOR.
*                POS = RELATIVE POSITION OF WEIGHT FACTOR.
*                DTY = DATA TYPE.
*                FWA = ADDRESS OF THE ELEMENT IN TABLE *DCDT*.
*                NSF = NUMBER OF RECORDS PER INTERVAL.
*                NIPP = (COMMON BLOCK *CIOCOMM*) NUMBER OF INTERVALS
*                      PER PAGE.
*
*     EXIT       THE AVERAGE, STANDARD DEVIATION, AND PERCENTAGE
*                OF THE DATA ELEMENT AT TEN INTERVALS ARE COMPUTED
*                AND PRINTED.
*                IF THE WEIGHT FACTOR IS THE CONSTANT 1, THE AVERAGE
*                WILL NOT BE PRINTED.
*                THE PERCENTAGE WILL NOT BE PRINTED IF THE ELEMENT
*                DOES NOT HAVE A WEIGHT FACTOR, OR THE WEIGHT FACTOR
*                IS THE CONSTANT 100.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM FLG        B;             # SUBBLOCK TITLE FLAG #
      ITEM MS1        C(40);         # SUBBLOCK TITLE #
      ITEM MS2        C(30);         # DATA ELEMENT NAME #
      ITEM WFA        U;             # WEIGHT FACTOR INFORMATION #
      ITEM WFP        U;             # WEIGHT FACTOR #
      ITEM POS        I;             # RELATIVE POSITIN OF *WFP* #
      ITEM DTY        U;             # DATA TYPE #
      ITEM FWA        U;             # ADDRESS OF ENTRY #
      ITEM NSF        I;             # NUMBER OF SAMPLES PER INTERVAL #
 
#
****  PROC DATELM - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC ACMSTA;                 # COMPUTE TOTAL STATISTICS #
        PROC COMPWF;                 # COMPUTE WEIGHT FACTOR #
        PROC PRDTEL;                 # PRINT ONE ROW OF DATA ELEMENT #
        FUNC SQRT R;                 # SQUARE ROOT #
        PROC WRITEV;                 # WRITE ONE VALUE #
        END
 
#
****  PROC DATELM - XREF LIST END.
#
 
      DEF AVGC       #"AV"#;         # AVERAGE #
      DEF PCTC       #"PC"#;         # PERCENTAGE #
      DEF SDVC       #"SD"#;         # STANDARD DEVIATION #
      DEF ZOPC       #"Z"#;          # *Z* OPTION #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM AV         R;             # AVERAGE VALUE #
      ITEM BCL        I;             # BEGIN COLUMN TO PRINT #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM NIP        R;             # NUMBER OF COLUMNS PER PAGE #
      ITEM NSR        R;             # NUMBER OF BLOCKS PER COLUMN #
      ITEM PRFLG      B;             # PROCESS FLAG #
      ITEM SM         R;             # INTERVAL SUM #
      ITEM SQ         R;             # INTERVAL SUM SQUARED #
      ITEM SSM        R;             # SUM OF SUBTOTAL #
      ITEM SSQ        R;             # SQUARED SUM OF SUBTOTAL #
      ITEM SWF        R;             # SUM OF WEIGHT FACTOR #
      ITEM WFT        R;             # WEIGHT FACTOR #
 
      ARRAY TEM [1:11] P(3);         # COMPUTED STATISTIC VALUES #
        BEGIN
        ITEM TEM$AV     R(00,00,60);  # AVERAGE #
        ITEM TEM$SD     R(01,00,60);  # STANDARD DEVIATION #
        ITEM TEM$PC     R(02,00,60);  # PERCENTAGE #
        END
 
 
 
#
*     BEGIN DATELM PROC.
#
 
      COMPWF(WFA,WFP,POS,WFT,PRFLG);   # COMPUTE WEIGHT FACTOR #
      IF (NOT PRFLG)                 # NOT TO PROCESS THIS ELEMENT #
      THEN
        BEGIN
        RETURN;
        END
 
      P<DCHD>=LOC(DBUF);
      P<DCDT>=LOC(DBUF[DCHL]);
      P<DDSM>=LOC(DBUF[DCHL + DCDC*DCDL*2]);
      P<DDSC>=LOC(DDDT);
 
#
*     CHECK IF ENTIRE LINE IS ZERO. IF SO, DO NOT PRINT THIS LINE.
#
 
      SM=0;
      SLOWFOR I=1 STEP 1 UNTIL NIPP
      DO
        BEGIN
        SM=SM + DCDT$SM[(I-1)*DCDL + FWA];
        END
 
      IF (SM EQ 0.0) AND (P$LO NQ ZOPC) AND (NIPP GR (DCDC-3))
      THEN
        BEGIN
        RETURN;
        END
 
      IF (NIPP LQ (DCDC-3))          # PRINT TOTAL ON THIS PAGE #
      THEN                           # CHECK IF TOTAL IS 0 #
        BEGIN
        IF (DDSM$IM[FWA] EQ 0) AND (P$LO NQ ZOPC)
        THEN
          BEGIN
          RETURN;
          END
 
        END
 
#
*     CHECK IF SUBTITLE HAS BEEN PRINTED.
#
 
      IF (FLG)                       # SUBTITLE NOT PRINTED #
      THEN                           # PRINT SUBTITLE #
        BEGIN
        WRITEV(MS1,CHRC,1,22,LFDC);
        FLG=FALSE;                   # INDICATE SUBTITLE WAS PRINTED #
        END
 
      WRITEV(MS2,CHRC,1,22,NLFC);    # WRITE DATA ELEMENT NAME #
 
#
*     COMPUTE AVERAGE, STANDARD DEVIATION, AND PERCENTAGE
*     FOR *NIPP* INTERVALS. THE COMPUTED VALUES ARE SAVED
*     IN ARRAY *TEM*.
#
 
      BCL=BCLC;                      # BEGIN COLUMN TO PRINT #
      NSR=NSF;                       # CONVERT TO REAL #
      NIP=NIPP;                      # CONVERT TO REAL #
      SSM=0.0;
      SSQ=0.0;
      SWF=0.0;
 
      IF (NIPP GR 0)
      THEN
        BEGIN  # COMPUTE INTERVAL STATISTICS #
        FASTFOR I=1 STEP 1 UNTIL NIPP
        DO
          BEGIN  # COMPUTE *AV*, *SD*, *PC* #
          SM=DCDT$SM[(I-1)*DCDL + FWA];
          SSM=SSM+SM;
          SQ=DCDT$SQ[(I-1)*DCDL+DCDC*DCDL+FWA];
          SSQ=SSQ+SQ;
          AV=SM/NSR;                 # AVERAGE #
          TEM$AV[I]=AV;
          TEM$SD[I]=SQRT(SQ/NSR - AV*AV);   # STANDARD DEVIATION #
          DCDT$SQ[(I-1)*DCDL+DCDC*DCDL+FWA]=TEM$SD[I];  # SAVE *SD* #
          DCDT$SM[(I-1)*DCDL+FWA]=TEM$AV[I];  # SAVE *AV* #
 
          IF (WFA EQ IWFC)           # INDIRECT WEIGHT FACTOR #
          THEN                       # GET WEIGHT FACTOR #
            BEGIN
            WFT=DCDT$SM[(I-1)*DCDL + DDSC$FW[WFP]]/NSR;
            SWF=SWF+WFT;
            END
 
          IF (WFT LQ 0)
          THEN
            BEGIN
            TEM$PC[I]=0.0;
            END
 
          ELSE
            BEGIN
            TEM$PC[I]=(AV/WFT)*100.0;  # PERCENTAGE #
            END
 
          END  # COMPUTE *AV*, *SD*, *PC* #
 
#
*     COMPUTE AVERAGE, STANDARD DEVIATION, AND PERCENTAGE
*     OF SUBTOTAL. THE PRECEDING INTERVALS ARE CONSIDERED
*     AS ONE INTERVAL.
#
 
        IF (TCOL GR (DCDC-3))        # PRINT SUBTOTAL #
        THEN
          BEGIN  # COMPUTE SUBTOTAL STATISTICS #
          I=NIPP+1;
          TEM$AV[I]=SSM/(NIP*NSR);   # AVERAGE #
          TEM$SD[I]=SQRT(SSQ/(NIP*NSR)-(TEM$AV[I]*TEM$AV[I]));
          IF (WFA EQ IWFC)           # INDIRECT WEIGHT FACTOR #
          THEN
            BEGIN
            WFT=SWF/NIP;             # WEIGHT FACTOR #
            END
 
          IF (WFT LQ 0)
          THEN
            BEGIN
            TEM$PC[I]=0.0;
            END
 
          ELSE
            BEGIN
            TEM$PC[I]=(TEM$AV[I]/WFT)*100.0;
            END
 
          BCL=BCL + I*10;
          END  # COMPUTE SUBTOTAL STATISTICS #
 
        ELSE                         # NO SUBTOTAL #
          BEGIN
          BCL=BCL + NIPP*10;
          END
 
        END  # COMPUTE INTERVAL STATISTICS #
 
#
*     PRINT VALUES SAVED IN ARRAY *TEM*.
*     AVERAGE VALUES ARE NOT PRINTED IF THE WEIGHT FACTOR
*     IS 1.
*     PERCENTAGE VALUES ARE NOT PRINTED IF *WFT* IS LESS THAN 0.
*     THE TOTAL STATISTIC VALUES ARE NOT PRINTED IF THERE ARE
*     MORE THAN 7 COLUMNS PRINTED ON A PAGE, I.E. IF THE NUMBER
*     OF INTERVALS PER PAGE *NIPP* IS GREATER THAN 7.
#
 
      IF (WFA NQ CWFC) OR (WFP NQ 1)
      THEN
        BEGIN  # PRINT *AV* #
        WRITEV(AVGC,CHRC,BCLC-2,2,NLFC);
        IF (NIPP GR 0)               # MORE THAN 1 COLUMN #
        THEN
          BEGIN
          PRDTEL(LOC(TEM$AV[1]),DTY,LOC(DDSM$AX[FWA]));
          END
 
        IF (NIPP LQ (DCDC-3))        # PRINT TOTAL ON SAME PAGE #
        THEN
          BEGIN
          ACMSTA(STVAL"AVST",FWA,DTY,BCL,0);  # TOTAL AVERAGE #
          END
 
        END  # PRINT *AV* #
 
      WRITEV(SDVC,CHRC,BCLC-2,2,NLFC);
      IF (NIPP GR 0)                 # MORE THAN 1 COLUMN #
      THEN
        BEGIN  # PRINT *SD* #
        PRDTEL(LOC(TEM$SD[1]),FLPC,LOC(DDSM$SX[FWA]));
        END  # PRINT *SD* #
 
      IF (NIPP LQ (DCDC-3))          # PRINT TOTAL ON SAME PAGE #
      THEN
        BEGIN
        ACMSTA(STVAL"SDST",FWA,FLPC,BCL,0);  # STANDARD DEVIATION #
        END
 
      IF (WFT GQ 0.0)                # PERCENTAGE TO BE PRINTED #
      THEN
        BEGIN  # PRINT *PC* #
        WRITEV(PCTC,CHRC,BCLC-2,2,NLFC);
        IF (NIPP GR 0)               # MORE THAN 1 COLUMN #
        THEN
          BEGIN
          PRDTEL(LOC(TEM$PC[1]),FLPC,LOC(DDSM$PX[FWA]));
          END
 
        IF (WFA EQ IWFC)             # INDIRECT WEIGHT FACTOR #
        THEN
          BEGIN
          WFT=DDSM$SM[DDSC$FW[WFP]]/ACNS;  # TOTAL WEIGHT FACTOR #
          END
 
        IF (NIPP LQ (DCDC-3))        # TOTAL IS PRINTED ON SAME PAGE #
        THEN
          BEGIN
          ACMSTA(STVAL"PCST",FWA,FLPC,BCL,WFT);  # TOTAL PERCENTAGE #
          END
 
        END  # PRINT *PC* #
 
      RETURN;
      END  # DATELM #
 
      TERM
PROC DECODE((DTA),(BFA));
# TITLE DECODE - DECODE DATA.  #
 
      BEGIN  # DECODE #
 
#
**    DECODE - DECODE DATA.
*
*     DECODE DATA IN *CIO* INPUT BUFFER, AND PUT THEM
*     IN CORRESPONDING DECODED BUFFER.
*
*     PROC DECODE((DTA),(BFA))
*
*     ENTRY      DTA = ADDRESS OF DATA DESCRIPTION TABLE
*                      (*DDHD* OR *DDDT*).
*                BFA = ADDRESS OF THE BUFFER WHERE THE DECODED DATA
*                      ARE TO BE SAVED (*DCHD* OR *DCDT*).
*                IBWA = CURRENT *CIO* INPUT BUFFER ADDRESS.
*
*     EXIT       IBWA = ADDRESS OF NEXT *CIO* INPUT BUFFER WORD.
*                DECODED DATA ARE ACCUMULATED IN THE APPROPRIATE
*                BUFFER.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM BFA        I;             # BUFFER ADDRESS #
      ITEM DTA        I;             # DATA DESCRIPTOR TABLE ADDRESS #
 
#
****  PROC DECODE - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        FUNC GETVAL I;               # GET VALUE FROM *CIO* BUFFER #
        PROC PERROR;                 # PROCESS ERROR #
        END
 
#
**** PROC DECODE - XREF LIST END.
#
 
      DEF CNIC       #"CNIL"#;       # FAST LOOP SAMPLE #
      DEF CPWC       #5#;            # NUMBER OF BYTES #
      DEF CTMC       #"CTML"#;       # MEDIUM LOOP SAMPLE #
      DEF CTOC       #"CTOL"#;       # SLOW LOOP SAMPLE #
      DEF HDLC       #0#;            # HEADER LOOP FLAG #
      DEF PDTC       #"PDTM"#;       # PACKED DATE AND TIME #
      DEF SNLC       #4#;            # SNAP SHOT LOOP FLAG #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM AV         R;             # AVERAGE VALUE #
      ITEM BA         I;             # BYTE ADDRESS OF *CIO* BUFFER #
      ITEM BASE       I;             # BEGIN ADDRESS OF REPEAT GROUP #
      ITEM C          I;             # DECODED DATA BUFFER ADDRESS #
      ITEM CQ         I;             # DECODED DATA BUFFER ADDRESS #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM IC         I;             # INCREMENTOR #
      ITEM J          I;             # FOR LOOP CONTROL #
      ITEM K          I;             # FOR LOOP CONTROL #
      ITEM L          I;             # FOR LOOP CONTROL #
      ITEM LMP        I;             # LENGTH MULTIPLIER #
      ITEM LN         I;             # LENGTH OF ENTRY #
      ITEM M          I;             # FOR LOOP CONTROL #
      ITEM NM         C(4);          # DATA ELEMENT NAME #
      ITEM OF         I;             # OFFSET #
      ITEM PR         I;             # NUMBER OF PP WORDS OCCUPIED #
      ITEM TP         U;             # DATA TYPE OF ELEMENT #
      ITEM VL         I;             # DECODED VALUE #
      ITEM VLR        R;             # DECODED VALUE #
 
      BASED
      ARRAY BUF [0:0] P(1);          # DECODED BUFFER #
        BEGIN  # ARRAY BUF #
        ITEM BUF$WD     U(00,00,60);  # DECODED DATA #
        ITEM BUF$SQ     R(00,00,60);  # SUM SQUARE #
        ITEM BUF$SM     R(00,00,60);  # SUM #
        ITEM BUF$ET     U(00,00,30);  # INTERVAL START TIME #
        ITEM BUF$BT     U(00,30,30);  # INTERVAL END TIME #
        END  # ARRAY BUF #
 
      ARRAY SPT [1:3] P(1);          # LOOP SAMPLE TIMES #
        BEGIN  # ARRAY SPT #
        ITEM SPT$WD     I(00,00,60);  # SAMPLE TIME #
        END  # ARRAY SPT #
 
 
 
 
 
 
#
*     BEGIN DECODE PROC.
#
 
      P<DCHD>=LOC(DBUF);
      P<DDSM>=LOC(DBUF[DCHL + DCDC*DCDL*2]);
      P<MPAR>=DTA;
      P<DDSC>=LOC(DDHD);
      P<BUF>=BFA;
      BA=IBWA*CPWC;
 
      IF (MPAR$TP[0] NQ HDLC)        # NOT HEADER BLOCK #
      THEN
        BEGIN  # GET LOOP SAMPLE TIMES #
        FASTFOR I=1 STEP 1 UNTIL 3
        DO
          BEGIN
          SPT$WD[I]=GETVAL(BA+SPLA$WD[I],2);
          END
 
        END  # GET LOOP SAMPLE TIMES #
 
#
*     FOLLOW TABLE *MPAR* TO EXTRACT DATA FROM *CIO* BUFFER AND PUT
*     THEM IN THE DECODED DATA BUFFER.
*     THE VALUES STORED IN THE DECODED DATA BUFFER FOR THE DATA
*     BLOCK ELEMENTS ARE THE CUMULATIVE AVERAGES. THE AVERAGE OF
*     EACH DATA BLOCK ELEMENT IS COMPUTED BY TAKING THE EXTRACTED
*     VALUE AND DIVIDING IT BY THE RESPECTIVE LOOP-S SAMPLE TIME
*     (*SPT* ARRAY). THE SQUARED AVERAGES ARE ALSO COMPUTED FOR
*     THE DATA BLOCK ELEMENTS.
#
 
      C=0;                           # BEGIN ADDRESS TO STORE AVERAGE #
      OF=DCDL*DCDC;                  # OFFSET #
      J=0;
 
      SLOWFOR M=0 WHILE (MPAR$WD[J] NQ 0)
      DO
        BEGIN  # FOLLOW TABLE *MPAR* #
        BASE=J;
        LMP=1;
        IF (MPAR$LMP[J] NQ NULL)
        THEN
          BEGIN
          LMP=DCHD$WD[DDSC$FW[MPAR$LMP[J]]];  # REPEAT GROUP LENGTH #
          END
 
#
*     *LMP* IS GREATER THAN 1 IF THE REPEAT GROUP HAS
*     MULTIPLE ENTRIES.
#
 
        FASTFOR K=1 STEP 1 UNTIL LMP
        DO
          BEGIN  # COLLECT REPEAT GROUP VALUES #
          J=BASE;
          IC=MPAR$IC[J];
 
#
*     *IC* IS THE SIZE OF THE REPEAT GROUP.
*     SINGLE ELEMENTS HAVE *IC* EQUAL TO 1.
#
 
          FASTFOR L=1 STEP 1 UNTIL IC
          DO
            BEGIN  # COLLECT ONE ENTRY OF REPEAT GROUP #
            NM=MPAR$NM[J];           # NAME #
            TP=MPAR$TP[J];           # TYPE #
            LN=MPAR$LN[J];           # LENGTH #
            PR=MPAR$PR[J];           # PRECISION #
            IF (PR GR CPWC)
            THEN
              BEGIN
              LN=(PR/CPWC)*LN;
              PR=CPWC;
              END
 
#
*     *LN* IS GREATER THAN 1 IF THE ELEMENT HAS MULTIPLE
*     ENTRIES.
#
 
            FASTFOR I=1 STEP 1 UNTIL LN
            DO
              BEGIN  # COLLECT VALUE OF ONE ENTRY #
              CQ=C + OF;             # ADDRESS OF SQUARED AVERAGE #
              VL=GETVAL(BA,PR);      # GET VALUE FROM *CIO* BUFFER #
 
              IF (TP EQ HDLC)        # HEADER BLOCK #
                OR (TP EQ SNLC)      # SNAPSHOT LOOP #
              THEN
                BEGIN  # COLLECT VALUES #
 
#
*     HEADER BLOCK AND SNAPSHOT LOOP DATA ELEMENTS ARE NOT CUMULATIVE
*     VALUES.
#
 
                IF (NM EQ PDTC)      # PACKED DATE AND TIME #
                THEN
                  BEGIN  # GET TIME #
                  BUF$ET[CQ]=VL-(VL/SHFC)*SHFC;  # INTERVAL END TIME #
                  IF (DDSM$BT[C] EQ 0) # TOTAL *BT* NOT COLLECTED #
                  THEN
                    BEGIN
                    DDSM$BT[C]=VL;  # TOTAL BEGIN TIME #
                    END
 
                  IF (BUF$BT[CQ] EQ 0) # INTERVAL *BT* NOT COLLECTED #
                  THEN
                    BEGIN
                    BUF$BT[CQ]=BUF$ET[CQ];  # INTERVAL BEGIN TIME #
                    END
 
                  END  # GET TIME #
 
                BUF$WD[C]=VL;
                IF (TP EQ SNLC)      # SNAPSHOT LOOP #
                THEN
                  BEGIN
                  DDSM$IM[C]=VL;
                  END
 
                END  # COLLECT VALUES #
 
              ELSE                   # FAST, MEDIUM, SLOW LOOP #
                BEGIN  # DECODE DATA BLOCK VALUES #
 
#
*     THE FAST, MEDIUM, AND SLOW LOOP DATA ELEMENTS ARE CUMULATIVE
*     VALUES. THE VALUES SAVED IN THE DECODED BUFFER ARE CUMULATIVE
*     AVERAGE VALUES. THE AVERAGE VALUE IS COMPUTED BY TAKING THE
*     VALUE DECODED FROM THE INPUT BUFFER (READ IN FROM THE DATA
*     FILE) AND DEVIDE IT BY THE RESPECTIVE LOOP SAMPLE TIME.
*     THE AVERAGE SQUARE IS ALSO COMPUTED AND SAVED IN THE DECODED
*     BUFFER FOR EACH DATA BLOCK ELEMENTS.
#
 
                IF (NM EQ CNIC)
                  OR (NM EQ CTMC)
                  OR (NM EQ CTOC)    # LOOP SAMPLE TIMES #
                THEN                 # ACCUMULATE SAMPLE TIMES #
                  BEGIN
                  BUF$WD[C]=BUF$WD[C] + VL;
                  DDSM$IM[C]=DDSM$IM[C] + VL;
                  END
 
                ELSE
                  BEGIN  # COMPUTE CUMULATIVE *AV* AND SQUARED *AV* #
                  IF (SPT$WD[TP] NQ 0)  # NUMBER OF SAMPLES .NE. 0 #
                  THEN
                    BEGIN
                    VLR=VL;
                    AV=VLR/SPT$WD[TP];
                    BUF$SM[C]=BUF$SM[C] + AV;
                    BUF$SQ[CQ]=BUF$SQ[CQ] + AV*AV;
                    DDSM$SM[C]=DDSM$SM[C] + AV;
                    DDSM$SQ[C]=DDSM$SQ[C] + AV*AV;
                    END
 
                  END  # COMPUTE CUMULATIVE *AV* AND SQUARED *AV* #
 
                END  # DECODE DATA BLOCK VALUES #
 
              C=C+1;                 # NEXT DECODED BUFFER ADDRESS #
              BA=BA+PR;              # NEXT *CIO* BUFFER BYTE ADDRESS #
              END  # COLLECT VALUE OF ONE ENTRY #
 
            J=J+1;
            END  # COLLECT ONE ENTRY OF REPEAT GROUP #
 
          END  # COLLECT REPEAT GROUP VALUES #
 
        END  # FOLLOW TABLE *MPAR* #
 
#
*     CHECK IF THERE IS ANY MISSING ELEMENTS. THE VALUE OF
*     *IBWA* HAS TO BE A MULTIPLE OF *IBNW*, FOR THE *CIO* BUFFER
*     HAS TO CONTAIN A MULTIPLE NUMBER OF DATA BLOCKS OR
*     HEADER BLOCK.
#
 
      C=BA/CPWC;
      IBWA=C+1;                      # NEXT *CIO* BUFFER ADDRESS #
      J=BA - (C*CPWC);
      IF (J NQ 0)
      THEN
        BEGIN
        C=C+1;
        END
 
      I=IBNW - (IBNW/C)*C;
      IF (I NQ 0)                    # NOT A MULTIPLE OF *IBNW* #
      THEN
        BEGIN
        PERROR(ERM6,FATAL,NULL);     # DATA FILE CONTENT ERROR #
        END
 
      RETURN;
      END  # DECODE #
 
      TERM
PROC DETMXM(MXP,MNP,(MXI),(MNI),(DTY));
# TITLE DETMXM - DETERMINE MAXIMUM AND MINIMUM VALUES.  #
 
      BEGIN  # DETMXM #
 
#
**    DETMXM - DETERMINE MAXIMUM AND MINIMUM VALUES.
*
*     DETERMINE THE MINIMUM AND MAXIMUM VALUES OF ONE
*     REPORT LINE. THE MAXIMUM VALUE IS INDICATED BY BRACKETS,
*     THE MINIMUM VALUE IS INDICATED BY PARENTHESES.
*
*     PROC DETMXM(MXP,MNP,(MXI),(MNI),(DTY))
*
*     ENTRY      MXP = MAXIMUM VALUE ADDRESS.
*                MNP = MINIMUM VALUE ADDRESS.
*                MXI = INTERVAL CONTAINING MAXIMUM VALUE.
*                MNI = INTERVAL CONTAINING MINIMUM VALUE.
*                DTY = DATA TYPE.
*
*     EXIT       MAXIMUM AND MINIMUM VALUES ARE INDICATED BY
*                BRACKETS AND PARENTHESES, RESPECTIVELY.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM MXP        U;             # ADDRESS OF MAXIMUM VALUE #
      ITEM MNP        U;             # ADDRESS OF MINIMUM VALUE #
      ITEM MXI        I;             # COLUMN OF MAXIMUM VALUE #
      ITEM MNI        I;             # COLUMN OF MINIMUM VALUE #
      ITEM DTY        U;             # DATA TYPE #
 
#
****  PROC DETMXM - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        FUNC XCDD C(10);             # BINARY TO DISPLAY DECIMAL #
        FUNC XCED C(10);             # BINARY TO *E* FORMAT #
        FUNC XCOD C(10);             # BINARY TO DISPLAY OCTAL #
        FUNC XCFD C(10);             # BINARY TO DISPLAY REAL #
        PROC WRITEV;                 # WRITE DATA ELEMENT #
        END
 
#
****  PROC DETMXM - XREF LIST END.
#
 
      DEF BLKC       #" "#;          # BLANK #
      DEF LBKC       #"["#;          # LEFT BRACKET #
      DEF LPRC       #"("#;          # LEFT PARENTHESIS #
      DEF MAXF       #1.0E4#;        # MAXIMUM VALUE OF *F* FORMAT #
      DEF RBKC       #"]"#;          # RIGHT BRACKET #
      DEF RPRC       #")"#;          # RIGHT  PARENTHESIS #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM MN         I;             # TEMPORARY VALUE #
      ITEM MNF        R;             # TEMPORARY VALUE #
      ITEM MX         I;             # TEMPORARY VALUE #
      ITEM MXF        R;             # TEMPORARY VALUE #
 
      ARRAY OCV [0:0] P(1);          # OCTAL VALUE #
        BEGIN  # ARRAY OCV #
        ITEM OC$WD      C(00,00,10);  # VALUE #
        ITEM OC$NP      C(00,06,09);  # NO POSTFIX #
        END  # ARRAY OCV #
 
      ARRAY TM [0:0] P(1);           # TEMPORARY BUFFER #
        BEGIN  # ARRAY TM #
        ITEM TM$WD      C(00,00,10);  # DISPLAY CODE MINIMUM VALUE #
        ITEM TM$W1      C(00,00,09);  # VALUE WITH NO POSTFIX #
        END  # ARRAY TM #
 
      ARRAY TX [0:0] P(1);           # TEMPORARY BUFFER #
        BEGIN  # ARRAY TX #
        ITEM TX$WD      C(00,00,10);  # DISPLAY CODE MAXIMUM VALUE #
        ITEM TX$W1      C(00,00,09);  # VALUE WITH NO POSTFIX #
        END  # ARRAY TX #
 
      BASED
      ARRAY VLMN [0:0] P(1);         # MINIMUM VALUE #
        BEGIN  # ARRAY VLMN #
        ITEM VLMN$F     R(00,00,60);  # REAL VALUE #
        ITEM VLMN$N     I(00,00,60);  # INTEGER VALUE #
        END  # ARRAY VLMN #
 
      BASED
      ARRAY VLMX [0:0] P(1);         # MAXIMUM VALUE #
        BEGIN  # ARRAY VLMX #
        ITEM VLMX$F     R(00,00,60);  # REAL VALUE #
        ITEM VLMX$N     I(00,00,60);  # INTEGER VALUE #
        END  # ARRAY VLMX #
 
 
 
 
 
#
*     BEGIN DETMXM PROC.
#
 
      IF (P$L EQ NULL)               # NO REPORT FILE #
      THEN
        BEGIN
        RETURN;
        END
 
#
*     CONVERT MAXIMUM AND MINIMUM VALUES TO DISPLAY CODE.
#
 
      P<VLMX>=LOC(MXP);
      P<VLMN>=LOC(MNP);
      IF (DTY EQ FLPC)               # REAL VALUE #
      THEN
        BEGIN
        IF (VLMX$F[0] GQ MAXF)
        THEN
          BEGIN  # CONVERT TO *E* FORMAT #
          MXF=VLMX$F[0];
          TX$WD[0]=XCED(MXF);
          END  # CONVERT TO *E* FORMAT #
 
        ELSE
          BEGIN  # CONVERT TO *F* FORMAT #
          MX=VLMX$F[0]*1000.0 + 0.5;
          TX$WD[0]=XCFD(MX);
          END  # CONVERT TO *F* FORMAT #
 
        IF (VLMN$F[0] GQ MAXF)
        THEN
          BEGIN  # CONVERT TO *E* FORMAT #
          MNF=VLMN$F[0];
          TM$WD[0]=XCED(MNF);
          END  # CONVERT TO *E* FORMAT #
 
        ELSE
          BEGIN  # CONVERT TO *F* FORMAT #
          MN=VLMN$F[0]*1000.0 + 0.5;
          TM$WD[0]=XCFD(MN);
          END  # CONVERT TO *F* FORMAT #
 
        END
 
      ELSE
        BEGIN
        IF (DTY EQ INTC)             # INTEGER VALUE #
        THEN
          BEGIN
          TX$WD[0]=XCDD(VLMX$N[0]);
          TM$WD[0]=XCDD(VLMN$N[0]);
          END
 
        ELSE                         # OCTAL VALUE #
          BEGIN
          OC$WD[0]=XCOD(VLMX$N[0]);
          TX$W1[0]=OC$NP[0];
          OC$WD[0]=XCOD(VLMN$N[0]);
          TM$W1[0]=OC$NP[0];
          END
 
        END
 
#
*     ENCLOSE THE MAXIMUM AND MINIMUM VALUES BY BRACKETS AND
*     PARENTHESES, RESPECTIVELY.
#
 
      SLOWFOR I=0 STEP 1 WHILE (C<I,1>TX$WD[0] EQ BLKC) DO;
      MX=MXI*10 + I + 14;
      WRITEV(LBKC,CHRC,MX,1,NLFC);
      MX=BCLC + MXI*10;
      WRITEV(RBKC,CHRC,MX,1,NLFC);
 
      SLOWFOR I=0 STEP 1 WHILE (C<I,1>TM$WD[0] EQ BLKC) DO;
      MN=MNI*10 + I + 14;
      WRITEV(LPRC,CHRC,MN,1,NLFC);
      MN=BCLC + MNI*10;
      WRITEV(RPRC,CHRC,MN,1,NLFC);
      RETURN;
      END  # DETMXM #
 
      TERM
FUNC DTMNUM((VALUE),(FORM),(PDOS)) I;
# TITLE DTMNUM - CONVERT DATE/TIME TO NUMBER.  #
 
      BEGIN  # DTMNUM #
 
#
**    DTMNUM - CONVERT DATE/TIME TO NUMBER.
*
*     CONVERT DISPLAY DATE/TIME TO THE PACKED FORMAT.
*
*     FUNC DTMNUM((VALUE),(FORM),(PDOS))
*
*     ENTRY      VALUE = VALUE TO BE CONVERTED.
*                FORM = IF TRUE, THE VALUE IS IN FORMAT
*                       XX.YY.ZZ.
*                       IF FALSE, THE VALUE IS IN FORMAT
*                       XXYYZZ.
*                PDOS = IF TRUE, THE PACKED DATE 1970 OFFSET APPLIES.
*                       IF FALSE, NO OFFSET IS APPLIED.
*
*     EXIT       VALUE IS CONVERTED TO PACKED FORMAT, AS IN
*                THE PACKED DATE AND TIME FORMAT.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM VALUE       C(10);         # VALUE TO BE CONVERTED #
      ITEM FORM       B;             # FORMAT OF DATE OR TIME #
      ITEM PDOS       B;             # APPLY PACKED DATE OFFSET #
 
#
****  FUNC DTMNUM - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC PERROR;                 # PROCESS ERROR #
        END
 
#
****  FUNC DTMNUM - XREF LIST END.
#
 
      DEF ZERC       #"0"#;          # CHARACTER 0 #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM E          I;             # EXPONENTIAL #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM N          I;             # TEMPORARY VARIABLE #
      ITEM T          U;             # TIME #
 
      ARRAY TM [0:0] P(1);           # VALUE TO BE CONVERTED #
        BEGIN  # ARRAY TM #
        ITEM TM$WD      C(00,00,10);  # VALUE #
        ITEM TM$XX      C(00,00,02);  # XX OF XXYYZZ #
        ITEM TM$YY      C(00,12,02);  # YY OF XXYYZZ #
        ITEM TM$ZZ      C(00,24,02);  # ZZ OF XXYYZZ #
 
        ITEM TM$X1      C(00,06,02);  # XX OF XX.YY.ZZ #
        ITEM TM$D1      C(00,18,01);  # DELIMITER #
        ITEM TM$Y1      C(00,24,02);  # YY OF XX.YY.ZZ #
        ITEM TM$D2      C(00,36,01);  # DELIMITER #
        ITEM TM$Z1      C(00,42,02);  # ZZ OF XX.YY.ZZ #
        END  # ARRAY TM #
 
 
 
 
 
#
*     BEGIN DTMNUM FUNC.
#
 
      TM$WD[0]=VALUE;
 
      IF (FORM)                      # FORMAT XX.YY.ZZ #
      THEN                           # CONVERT TO FORMAT XXYYZZ #
        BEGIN
        TM$XX[0]=TM$X1[0];
        TM$YY[0]=TM$Y1[0];
        TM$ZZ[0]=TM$Z1[0];
        END
 
      IF (TM$WD[0] EQ 0)
      THEN
        BEGIN
        DTMNUM=0;
        RETURN;
        END
 
#
*     CONVERT TO THE PACKED FORMAT.
#
 
      N=0;
      E=1;
      FASTFOR I=0 STEP 2 UNTIL 5
      DO
        BEGIN
        T=C<5-I,1>TM$WD[0] - ZERC;
        T=(C<4-I>TM$WD[0] - ZERC)*10 + T;
        N=N+T*E;
        E=E*64;
        END
 
      IF (PDOS)                      # CONVERTING DATE #
      THEN                           # CHECK DATE RANGE #
        BEGIN
        IF (N LS Y70C)               # DATE IN 21ST CENTURY #
        THEN
          BEGIN
          N=N+Y30C;                  # BIAS 21ST CENTURY DATES #
          END
        ELSE                         # DATE IN 20TH CENTURY #
          BEGIN
          N=N-Y70C;                  # BIAS 20TH CENTURY DATES #
          END
        END
 
      DTMNUM=N;
      RETURN;
      END  # DTMNUM #
 
      TERM
PROC GETMSG((ENT),MSG);
# TITLE GETMSG - GET REPORT MESSAGE.  #
 
      BEGIN  # GETMSG #
 
#
**    GETMSG - GET REPORT MESSAGE.
*
*     GET MESSAGES FROM COMMON BLOCK *DSPTTXT*.
*
*     PROC GETMSG((ENT),MSG)
*
*     ENTRY      ENT = INDEX OF TABLE *DSPT* ENTRY.
*
*     EXIT       MSG = MESSAGE EXTRACTED FROM COMMON BLOCK *DSPTTXT*.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM ENT        I;             # INDEX OF TABLE *DSPT* #
      ITEM MSG        C(50);         # REPORT TITLES #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM BA         I;             # BYTE ADDRESS #
      ITEM BC         I;             # BEGINNING CHARACTER POSITION #
      ITEM LN         I;             # MESSAGE LENGTH IN CHARACTER #
 
      BASED
      ARRAY TXT [0:0] P(1);          # MESSAGE BUFFER #
        BEGIN  # ARRAY TXT #
        ITEM TXT$MS     C(00,00,60);  # MESSAGE #
        END  # ARRAY TXT #
 
 
 
 
 
#
*     BEGIN GETMSG PROC.
#
 
      LN=DSPT$LN[ENT];               # NUMBER OF CHARACTERS #
      BC=DSPT$BC[ENT];               # BEGINNING CHARACTER POSITION #
      BA=BC - (BC/10)*10;
      P<TXT>=LOC(DSTX$TX[BC/10]);
      MSG=C<BA,LN>TXT$MS[0];
      RETURN;
      END  # GETMSG #
 
      TERM
FUNC GETVAL((BA),(PR)) I;
# TITLE GETVAL - GET VALUE FROM *CIO* BUFFER.  #
 
      BEGIN  # GETVAL #
 
#
**    GETVAL - GET VALUE FROM *CIO* BUFFER.
*
*     EXTRACT VALUES FROM THE *CIO* BUFFER OF THE DATA FILE.
*
*     FUNC GETVAL((BA),(PR)) I
*
*     ENTRY      BA = BYTE ADDRESS OF THE VALUE TO BE EXTRACTED.
*                PR = NUMBER OF BYTES TO BE EXTRACTED.
*
*     EXIT       THE VALUE IS EXTRACTED FROM BUFFER *WSAI*.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM BA         I;             # BYTE ADDRESS #
      ITEM PR         I;             # PRECISION #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM BC         I;             # BYTE ADDRESS #
      ITEM T          I;             # TEMPORARY VALUE #
      ITEM WA         I;             # *CIO* BUFFER WORD ADDRESS #
 
      BASED
      ARRAY WSA [0:0] P(1);          # WORKING BUFFER #
        BEGIN  # ARRAY WSA #
        ITEM WSA$C      C(00,00,20);  # BUFFER ENTRY #
        END  # ARRAY WSA #
 
 
 
 
 
#
*     BEGIN GETVAL FUNC.
#
 
      WA=BA/5;                       # ADDRESS TO EXTRACT THE VALUE #
      P<WSA>=LOC(WSAI$WD[WA]);
      T=BA*2;                        # NUMBER OF CHARACTERS #
      BC=T - (T/10)*10;              # BEGIN CHARACTER POSITION #
      GETVAL=C<BC,PR*2>WSA$C[0];
      RETURN;
      END  # GETVAL #
 
      TERM
PROC HDRELM((ENP),(FCL),(LCL));
# TITLE HDRELM - PRINT HEADER BLOCK ELEMENT.  #
 
      BEGIN  # HDRELM #
 
#
**    HDRELM - PRINT HEADER BLOCK ELEMENT.
*
*     PRINT ONE ELEMENT OF HEADER BLOCK.
*
*     PROC HDRELM((ENP),(FCL),(LCL))
*
*     ENTRY      ENP = INDEX OF THE *DSPT* ENTRY POINTING TO
*                      THE HEADER BLOCK ELEMENT BEING PROCESSED.
*                FCL = BEGINNING COLUMN TO PRINT THE HEADER BLOCK
*                      ELEMENT NAME.
*                LCL = BEGINNING COLUMN TO PRINT THE HEADER BLOCK
*                      ELEMENT VALUE.
*
*     EXIT       THE HEADER BLOCK ELEMENT IS PRINTED TO THE REPORT
*                FILE.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM ENP        I;             # INDEX OF DSPT ENTRY #
      ITEM FCL        I;             # BEGIN COLUMN TO PRINT NAME #
      ITEM LCL        I;             # BEGIN COLUMN TO PRINT VALUE #
 
#
****  PROC HDRELM - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC GETMSG;                 # GET TITLE FROM TABLE *DSPTTXT* #
        PROC WRITEV;                 # WRITE DATA ELEMENT #
        END
 
#
****  PROC HDRELM - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM BL         I;             # BIT LENGTH #
      ITEM BT         I;             # BIT POSITION #
      ITEM D          I;             # DATA TYPE #
      ITEM J          I;             # POINTER TO *DDHD* TABLE #
      ITEM L          I;             # TITLE LENGTH IN CHARACTERS #
      ITEM MSG        C(50);         # TEMPORARY BUFFER #
      ITEM T          I;             # POINTER TO *DCHD* TABLE #
      ITEM VALUE      I;             # TEMPORARY VALUE #
      ITEM WC         I;             # WORD COUNT #
 
 
 
 
 
#
*     BEGIN HDRELM PROC.
#
 
      P<DCHD>=LOC(DBUF);
      P<DDSC>=LOC(DDHD);
      J=DSPT$PT[ENP];                # INDEX OF TABLE *DDSC* #
      L=DSPT$LN[ENP];
      T=DDSC$FW[J];                  # INDEX OF TABLE *DCHD* #
      D=DDSC$TY[J];                  # DATA TYPE #
      GETMSG(ENP,MSG);
      WRITEV(MSG,CHRC,FCL,L,NLFC);
      BL=DSPT$BL[ENP];               # GET BIT LENGTH #
      WC=DSPT$WC[ENP];               # WORD COUNT #
      IF (BL EQ 0)                   # ACCESS FULL WORD #
      THEN
        BEGIN
        VALUE=DCHD$WD[T+WC];
        END
 
      ELSE                           # ACCESS PARTIAL WORD #
        BEGIN
        BT=DSPT$BT[ENP];
        VALUE=B<BT,BL>DCHD$WD[T+WC];
        END
 
      WRITEV(VALUE,D,LCL,10,LFDC);
      RETURN;
      END  # HDRELM #
      TERM
PROC HEADER(TMED,HDDC,(LSTM));
# TITLE HEADER - PROCESS HEADER BLOCK.  #
 
      BEGIN  # HEADER #
 
#
**    HEADER - PROCESS HEADER BLOCK.
*
*     *HEADER* BUILDS THE REPORT TITLE AND PROCESSES THE HEADER BLOCK
*     OF EACH FILE IN THE DATA FILE.
*
*     PROC HEADER(TMED,HDDC,(LSTM))
*
*     ENTRY      HDDC = TRUE IF HEADER BLOCK HAS BEEN DECODED.
*                LSTM = TIME OF LAST RECORD.
*
*     EXIT       TMED = TRUE IF *N* PARAMETER EXCEEDS NUMBER OF FILES.
*                HDDC = FALSE
*                ELEMENTS IN HEADER BLOCK ARE PRINTED TO THE
*                REPORT FILE.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM TMED       B;             # EOI FLAG #
      ITEM HDDC       B;             # DECODE HEADER BLOCK FLAG #
      ITEM LSTM       U;             # ENDING TIME OF PREVIOUS FILE #
 
#
****  PROC HEADER - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC ADJUST;                 # ADJUST TABLES AND FIELD LENGTH #
        PROC BZFILL;                 # BLANK/ZERO FILL ITEM #
        PROC DECODE;                 # DECODE *CIO* INPUT BUFFER DATA #
        FUNC DTMNUM U;               # CONVERT DATE/TIME TO BINARY #
        PROC PERROR;                 # PROCESS ERROR #
        PROC PUTEST;                 # PRINT EST #
        PROC PUTHDR;                 # PRINT HEADER ELEMENTS #
        PROC PUTSCI;                 # PRINT JOB CONTROL BLOCK #
        PROC READRC;                 # READ AND SKIP #
        PROC RPHEAD;                 # PRINT *ACPD* TITLE #
        PROC WRITER;                 # *CIO* WRITER #
        PROC WRITEW;                 # *CIO* WRITEW #
        END
 
#
****  PROC HEADER - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
*CALL     COMABZF
 
#
*     LOCAL VARIABLES.
#
 
      ITEM D          I;             # TEMPORARY VARIABLE #
      ITEM L          I;             # TEMPORARY VARIABLE #
      ITEM STAT       I;             # I/O STATUS #
      ITEM T          I;             # TEMPORARY VARIABLE #
 
      BASED
      ARRAY HEAD [0:0] P(1);         # HEADER SYSTEM DESIGNATOR #
        BEGIN  # ARRAY HEAD #
        ITEM HEAD$SD    C(00,00,70);  # SYSTEM DESIGNATOR #
        END  # ARRAY HEAD #
 
      ARRAY TEXT [0:0] S(10);        # HEADER TEXT #
        BEGIN  # ARRAY TEXT #
        ITEM TXT$H1     C(00,00,16);  # *ACPD* VERSION #
        ITEM TXT$VR     C(01,00,10);  # VERSION NUMBER #
        ITEM TXT$H2     C(02,00,10)=["          "];  # BLANK FILL #
        ITEM TXT$SD     C(03,00,70);  # SYSTEM DESIGNATOR #
        END  # ARRAY TEXT #
 
 
 
 
 
#
*     BEGIN HEADER PROC.
#
 
      P<MPAR>=LOC(HDTR);
      P<DDSC>=LOC(DDHD);
      P<DCHD>=LOC(DBUF);
 
#
*     *HDDC* IS NOT TRUE IF *HEADER* IS CALLED TO PROCESS THE NEXT
*     DATA FILE. *HDDC* IS TRUE IF THE FIRST FILE IS BEING PROCESSED.
*     IF THE LATER IS TRUE, ALL THE ERROR CHECKING HAS BEEN DONE BY
*     *INITLZ*.
#
 
      IF (NOT HDDC)                  # HEADER BLOCK NOT DECODED #
      THEN
        BEGIN  # READ HEADER BLOCK OF NEXT FILE #
        READRC(STAT);                # READ HEADER BLOCK #
        IF (STAT NQ EORC)            # EOF OR EOI ENCOUNTERED #
        THEN
          BEGIN
          IF (IBNW GR 0)             # INPUT BUFFER NOT EMPTY #
          THEN
            BEGIN
            PERROR(ERM4,FATAL,NULL);   # DATA BLOCKS MISSING #
            END
 
          IF (P$N LS 9999999)        # EQUIVALENCED *N* PARAMETER #
          THEN
            BEGIN
            PERROR(ERM9,INFOM,NULL);   # *N* EXCEEDS NUMBER OF FILES #
            END
 
          TMED=TRUE;
          RETURN;
          END
 
        IF (P$VERS NQ WSAI$VS[0])    # *CPD* AND *ACPD* INCOMPATBLE #
        THEN
          BEGIN
          PERROR(ERM13,FATAL,NULL);  # CPD/ACPD VERSIONS MISMATCH #
          END
 
        IBWA=0;
        DECODE(LOC(HDTR),LOC(DCHD));  # DECODE HEADER BLOCK #
        ADJUST;                      # ADJUST TABLES AND FIELD LENGTH #
 
#
*     CHECK IF FILES IN CHRONOLOGICAL ORDER.
#
 
        T=DTMNUM(DCHD$WD[DDSC$FW[TIME]],TRUE,FALSE);
        D=DTMNUM(DCHD$WD[DDSC$FW[DATE]],TRUE,TRUE)*SHFC;
        IF (LSTM GR (D+T))           # DATA FILE NOT IN ORDER #
        THEN
          BEGIN
          PERROR(ERM8,FATAL,NULL);
          END
 
        END  # READ HEADER BLOCK OF NEXT FILE #
 
      ELSE                           # HEADER BLOCK HAS BEEN DECODED #
        BEGIN
        HDDC=FALSE;
        END
 
#
*     BUILD THE REPORT TITLE.
#
 
      T=DDSC$FW[CPDV];               # *ACPD* VERSION POINTER #
      TXT$VR[0]=DCHD$CW[T];
      TXT$H1[0]=" A C P D - VER  ";
 
      T=DDSC$FW[SYSV];               # SYSTEM DESIGNATOR POINTER #
      P<HEAD>=LOC(DCHD$CW[T]);
      T=MPAR$PR[SYSV]*2;
      BZFILL(HEAD,TYPFILL"BFILL",T);
      TXT$SD[0]=HEAD$SD[0];
 
      IF (P$L NQ NULL)               # REPORT FILE SPECIFIED #
      THEN
        BEGIN
        L=30 + T;                    # LENGTH OF HEADER TEXT #
        RPHEAD(OFFA,TEXT,2,L);       # SET UP *ACPD* TITLE #
        PUTHDR;                      # PRINT HEADER BLOCK ELEMENTS #
        PUTEST;                      # PRINT EST #
        PUTSCI;                      # PRINT JOB CONTROL BLOCK #
        END
 
      IF (P$S NQ NULL)               # SUMMARY FILE SPECIFIED #
      THEN                           # WRITE SUMMARY FILE #
        BEGIN
        WRITEW(FETS,DCHD,DCHL,0);
        WRITER(FETS,1);
        END
 
      RETURN;
      END  # HEADER #
 
      TERM
PROC INITLZ(HDDC,DTDC,EDTM);
# TITLE INITLZ - INITIALIZE PARAMETERS AND OPEN FILES.  #
 
      BEGIN  # INITLZ #
 
#
**    INITLZ - INITIALIZE PARAMETERS AND OPEN FILES.
*
*     PROCESS *ACPD* COMMAND PARAMETERS, INITIALIZE *ACPD*,
*     AND OPEN FILES.
*
*     PROC INITLZ(HDDC,DTDC,EDTM)
*
*     ENTRY      NONE.
*
*     EXIT       HDDC = INDICATE IF HEADER BLOCK HAS BEEN DECODED.
*                DTDC = INDICATE IF DATA BLOCK HAS BEEN DECODED.
*                TIME = TRUE IF BEGINNING TIME GREATER THAN
*                       ENDING TIME.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM HDDC       B;             # DECODED HEADER BLOCK FLAG #
      ITEM DTDC       B;             # DECODED DATA BLOCK FLAG #
      ITEM EDTM       B;             # ENDING TIME FLAG #
 
#
****  PROC INITLZ - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC ADJUST;                 # ADJUST TABLES AND FIELD LENGTH #
        PROC DECODE;                 # DECODE *CIO* INPUT BUFFER DATA #
        FUNC DTMNUM I;               # CONVERT TIME/DATE TO BINARY #
        PROC FILINFO;                # GET FILE INFORMATION #
        PROC MEMORY;                 # REQUEST MEMORY #
        PROC PAP;                    # PROCESS *ACPD* PARAMETER #
        PROC PERROR;                 # PROCESS ERROR #
        PROC READRC;                 # READ ONE RECORD FROM DATA FILE #
        PROC REPTLE;                 # PRINT REPORT SUBTITLE #
        PROC RPOPEN;                 # OPEN FILES #
        PROC ZSETFET;                # INITIALIZE *CIO* FET #
        END
 
#
****  PROC INITLZ - XREF LIST END.
#
 
      DEF CNIC       #"CNIL"#;       # FAST LOOP SAMPLE #
      DEF CTMC       #"CTML"#;       # MEDIUM LOOP SAMPLE #
      DEF CTOC       #"CTOL"#;       # SLOW LOOP SAMPLE #
      DEF MXVC       #1.0E20#;       # MAXIMUM VALUE #
      DEF NA         #"NA"#;         # NO ABORT FLAG #
      DEF RECALL     #1#;            # RECALL FLAG #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM BA         I;             # BYTE ADDRESS #
      ITEM CM         C(10)="CM";    # REQUEST CM FLAG #
      ITEM D          I;             # TEMPORARY VARIABLE #
      ITEM DM         I;             # TEMPORARY VARIABLE #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM J          I;             # FOR LOOP CONTROL #
      ITEM STAT       I;             # I/O STATUS #
      ITEM T          I;             # TEMPORARY VARIABLE #
      ITEM TM         I;             # TIME #
 
      ARRAY FINFO [0:0] P(5);        # *FILINFO* PARAMETER BLOCK #
        BEGIN  # ARRAY FINFO #
        ITEM FIN$FN     C(00,00,07);  # FILE NAME #
        ITEM FIN$LN     U(00,42,06)=[5];  # PARAMETER BLOCK LENGTH #
        ITEM FIN$US     U(00,48,12)=[1];  # COMPLETION STATUS #
        ITEM FIN$WD     U(01,00,60);  # PARAMETER BLOCK WORD #
        ITEM FIN$EI     B(01,36,01);  # EOI STATUS #
        ITEM FIN$EF     B(01,37,01);  # EOF STATUS #
        ITEM FIN$BI     B(01,38,01);  # BOI STATUS #
        END  # ARRAY FINFO #
 
      ARRAY STT [0:0] P(1);          # MEMORY ARGUMENT #
        BEGIN  # ARRAY STT #
        ITEM STT$RFL    U(00,00,30);  # REQUEST FIELD LENGTH #
        END  # ARRARY STT #
 
 
 
 
 
 
 
#
*     BEGIN INITLZ PROC.
#
 
      PAP;                           # PROCESS *ACPD* PARAMETERS #
 
#
*     OPEN FILES.
#
 
      ZSETFET(LOC(FETI),P$FN,LOC(WSAI),WSAL+1,FENL+1);
      FIN$FN[0]=P$FN;
      FILINFO(FINFO);                # CHECK STATUS OF INPUT FILE #
      IF (FIN$WD[0] EQ NULL)        # NO STATUS #
      THEN
        BEGIN
        PERROR(ERM11,FATAL,P$FN);    # DATA FILE NOT FOUND #
        END
 
      IF (FIN$EI[0])                 # EOI #
      THEN
        BEGIN
        PERROR(ERM12,FATAL,NULL);    # DATA FILE POSITIONED AT EOI #
        END
 
      IF (NOT (FIN$EF[0] OR FIN$BI[0]))  # NOT AT EOF NOR BOI #
      THEN
        BEGIN
        PERROR(ERM7,FATAL,NULL);
        END
 
      OFFA=LOC(FETO);
      IF (P$L NQ NULL)               # REPORT FILE SPECIFIED #
      THEN                           # OPEN REPORT FILE #
        BEGIN
        RPOPEN(P$L,OFFA,REPTLE);
        END
 
      IF (P$S NQ NULL)               # SUMMARY FILE SPECIFIED #
      THEN                           # OPEN SUMMARY FILE #
        BEGIN
        ZSETFET(LOC(FETS),P$S,LOC(WSAS),WSAL+1,FENL+1);
        END
 
#
*     REQUEST CURRENT FIELD LENGTH.
#
 
      MEMORY(CM,STT,RECALL,NA);
      CRFL=STT$RFL[0];               # CURRENT FIELD LENGTH #
      HGAD=CRFL;                     # HIGHEST ADDRESS #
 
#
*     CHECK IF *CPD* AND *ACPD* VERSIONS ARE THE SAME.
#
 
      READRC(STAT);                  # READ HEADER BLOCK #
      IF (STAT NQ EORC)              # EOF OR EOI ENCOUNTERED #
      THEN
        BEGIN
        PERROR(ERM5,FATAL,NULL);     # DATA FILE EMPTY #
        END
 
      IF (P$VERS NQ WSAI$VS[0])      # *CPD* AND *ACPD* INCOMPATBLE #
      THEN
        BEGIN
        PERROR(ERM13,FATAL,NULL);    # CPD/ACPD VERSIONS MISMATCH #
        END
 
#
*     VALIDATE BEGIN AND END TIMES.
*     IF NO *BD* SPECIFIED, BEGIN DATE IS THE DATE OF THE
*     HEADER RECORD OF THE CURRENT FILE.
*     IF NO *ED* SPECIFIED, END DATE IS THE SAME AS BEGIN DATE.
*     IF NO *ET*/*ED* SPECIFIED, END DATE IS SET TO MAXIMUM.
#
 
      P<DCHD>=LOC(DBUF);
      P<DDSC>=LOC(DDHD);
 
      IBWA=0;
      DECODE(LOC(HDTR),LOC(DCHD));   # DECODE HEADER BLOCK #
      ADJUST;                        # ADJUST TABLES AND FIELD LENGTH #
      HDDC=TRUE;                     # HEADER BLOCK HAS BEEN DECODED #
 
      IF (P$BD EQ NULL)              # NO BEGINNING DATE #
      THEN
        BEGIN
        DM=DTMNUM(DCHD$WD[DDSC$FW[DATE]],TRUE,TRUE)*SHFC;
        END
 
      ELSE                           # *BD* SPECIFIED #
        BEGIN
        DM=DTMNUM(P$BD,FALSE,TRUE)*SHFC;
        END
 
      P$BT=DM + DTMNUM(P$BT,FALSE,FALSE);
 
      IF (P$ED NQ NULL)              # END DATE SPECIFIED #
      THEN
        BEGIN
        P$ET=(DTMNUM(P$ED,FALSE,TRUE)*SHFC) + DTMNUM(P$ET,FALSE,FALSE);
        END
 
      ELSE                           # NO END DATE #
        BEGIN
        IF (P$ET NQ NULL)            # END TIME SPECIFIED #
        THEN
          BEGIN
          P$ET=DM + DTMNUM(P$ET,FALSE,FALSE);
          END
 
        ELSE                         # *ET*/*ED* ARE NOT SPECIFIED #
          BEGIN
          P$ET=MXDC*SHFC + MXTC;     # 33/12/31  23.59.59 #
          END
 
        END
 
      IF (P$BT GQ P$ET)              # BEGIN TIME .GE. END TIME #
      THEN
        BEGIN
        EDTM=TRUE;                   # ENDING TIME REACHED #
        RETURN;
        END
 
      TM=DTMNUM(DCHD$WD[DDSC$FW[DATE]],TRUE,TRUE)*SHFC;
      TM=TM + DTMNUM(DCHD$WD[DDSC$FW[TIME]],TRUE,FALSE);
      IF (P$BT GR TM)                # *BT* .GT. TIME OF FIRST
                                       DATA RECORD #
      THEN
        BEGIN
        DTDC=TRUE;                   # DECODE DATA BLOCK #
        END
 
      ELSE
        BEGIN
        DTDC=FALSE;                  # NOT DECODE DATA BLOCK #
        END
 
#
*     COMPUTE BYTE ADDRESSES OF SAMPLE TIMES IN
*     INPUT FILE-S WORKING STORAGE AREA.
#
 
      BA=0;
      P<MPAR>=LOC(DATT);
      SLOWFOR I=0 STEP 1 WHILE (MPAR$NM[I] NQ CTOC)
      DO
        BEGIN  # COMPUTE SAMPLE TIME BYTE ADDRESS #
        IF (MPAR$NM[I] EQ CNIC)      # FAST LOOP SAMPLE #
        THEN
          BEGIN
          SPLA$WD[MPAR$TP[I]]=BA;
          END
 
        ELSE
          BEGIN
          IF (MPAR$NM[I] EQ CTMC)    # MEDIUM LOOP SAMPLE #
          THEN
            BEGIN
            SPLA$WD[MPAR$TP[I]]=BA;
            END
 
          END
 
        BA=MPAR$LN[I]*MPAR$PR[I] + BA;
        END  # COMPUTE SAMPLE TIME BYTE ADDRESS #
 
      SPLA$WD[MPAR$TP[I]]=BA;        # SLOW LOOP SAMPLE #
 
      READRC(STAT);                  # READ FIRST DATA BLOCK #
      IF (STAT NQ EORC)              # NO DATA BLOCKS #
      THEN
        BEGIN
        PERROR(ERM4,FATAL,NULL);     # DATA BLOCKS MISSING #
        END
 
      P<DCDT>=LOC(DBUF[DCHL]);
      P<DDSM>=LOC(DBUF[DCHL + DCDC*DCDL*2]);
 
#
*     POSITION FILE AT CORRECT RECORD.
#
 
      STAT=0;
      IBWA=0;
 
      SLOWFOR J=0 WHILE (P$BT GR TM) AND (STAT NQ EOIC)
      DO
        BEGIN  # READ FILE #
        IF (IBWA GQ IBNW)            # INPUT BUFFER EXHAUSTED #
        THEN
          BEGIN  # GET NEXT BUFFER #
          READRC(STAT);              # READ NEXT RECORD #
          IBWA=0;
          IF (STAT NQ EORC)          # END OF CURRENT FILE #
          THEN
            BEGIN  # CHECK IF EOF OR EOI #
            IF (STAT EQ EOFC)        # PREVIOUS READ ENCOUNTERED EOF #
            THEN
              BEGIN  # GET NEXT FILE #
              READRC(STAT);          # READ HEADER BLOCK OF NEXT FILE #
              IF (STAT NQ EORC)      # NO DATA BLOCKS FOLLOW #
              THEN
                BEGIN
                PERROR(ERM4,FATAL,NULL);   # DATA BLOCKS MISSING #
                END
 
              DECODE(LOC(HDTR),LOC(DCHD));  # DECODE HEADER BLOCK #
              ADJUST;                # ADJUST TABLES AND FIELD LENGTH #
              P<DCDT>=LOC(DBUF[DCHL]);
              P<DDSM>=LOC(DBUF[DCHL + DCDC*DCDL*2]);
              P<DDSC>=LOC(DDHD);
 
              D=DTMNUM(DCHD$WD[DDSC$FW[DATE]],TRUE,TRUE)*SHFC;
                                     # GET DATE ON RECORD #
              T=DTMNUM(DCHD$WD[DDSC$FW[TIME]],TRUE,FALSE);
                                     # GET TIME ON RECORD #
              IF (TM GR (D+T))       # PREVIOUS TIME .GT.
                                       CURRENT TIME #
              THEN
                BEGIN
                PERROR(ERM8,FATAL,NULL);
                END
 
              TM=D + T;              # SET TO CURRENT TIME #
              TEST J;                # GO PROCESS DATA BLOCKS #
              END  # GET NEXT FILE #
 
            ELSE                     # PREVIOUS READ ENCOUNTERD *EOI* #
              BEGIN
              PERROR(ERM3,FATAL,NULL);   # BT/BD NOT FOUND #
              END
 
            END  # CHECK IF EOF OR EOI #
 
          END  # GET NEXT BUFFER #
 
        DECODE(LOC(DATT),LOC(DCDT));
        P<DDSC>=LOC(DDDT);
        TM=DCDT$WD[DDSC$FW[PDTM]];   # GET TIME #
 
#
*     REINITIALIZE BUFFER OF FIRST COLUMN.
#
 
        FASTFOR I=0 STEP 1 UNTIL DCDL - 1
        DO
          BEGIN
          DCDT$WD[I]=0;
          DCDT$WD[I + DCDL*DCDC]=0;
          DDSM$IM[I]=0;
          DDSM$IQ[I]=0;
          END
 
        END  # READ FILE #
 
      IF (P$ET LQ TM)                # READ PAST ENDING TIME #
      THEN
        BEGIN
        EDTM=TRUE;
        END
 
      RETURN;
      END  # INITLZ #
 
      TERM
PROC PERROR((ERCD),(EROR),(ERNM));
# TITLE PERROR - ISSUE ERROR MESSAGE.  #
 
      BEGIN  # PERROR #
 
#
**    PERROR - ISSUE ERROR MESSAGE.
*
*     ISSUE ERROR MESSAGE TO THE USER DAYFILE AND ABORT
*     THE JOB IF THE ERROR IS FATAL.
*
*     PROC PERROR(ERCD,EROR,ERNM)
*
*     ENTRY      ERCD = ERROR CODE.
*                EROR = ERROR LEVEL.
*                ERNM = ERROR NAME.
*
*     EXIT       JOB ABORTED IF *EROR*=FATAL.
*                OTHERWISE, RETURN TO CALLING PROGRAM.
*
*     MESSAGES
*
*     1. ACPD ARGUMENT ERROR - XX.
*     2. ACPD/CPD VERSIONS MISMATCH.
*     3. BT/BD NOT FOUND.
*     4. DATA BLOCKS MISSING.
*     5. DATA ELEMENT NAME UNDEFINED - XXXX.
*     6. DATA FILE CONTENT ERROR.
*     7. DATA FILE EMPTY.
*     8. DATA FILE NOT AT BEGINNING OF FILE.
*     9. DATA FILE NOT FOUND - XXXXXXX.
*    10. DATA FILE NOT IN CHRONOLOGICAL ORDER.
*    11. DATA FILE POSITIONED AT EOI.
*    12. IN AND IC PARAMETER CONFLICT.
*    13. IN LESS THAN FILE WRITE TIME.
*    14. N EXCEEDS NUMBER OF FILES.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM ERCD       I;             # ERROR CODE #
      ITEM EROR       I;             # ERROR LEVEL #
      ITEM ERNM       C(10);         # ERROR NAME #
 
#
****  PROC PERROR - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC ABORT;                  # ABORT JOB #
        PROC MESSAGE;                # ISSUE DAYFILE MESSAGES #
        END
 
#
****  PROC PERROR - XREF LIST END.
#
 
      DEF BLKC       #" "#;          # BLANK #
      DEF DOLC       #"$"#;          # DOLLAR SIGN #
      DEF PRDC       #"."#;          # PERIOD #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM J          I;             # FOR LOOP CONTROL #
      ITEM L          I;             # FOR LOOP CONTROL #
 
      ARRAY ERMS [1:ERMSC] S(4);     # ERROR MESSSAGES #
        BEGIN  # ARRAY ERMS #
        ITEM ER$MS      C(00,00,38) =  # ERROR MESSAGES #
 
                      [" ACPD ARGUMENT ERROR - $.",
                       " DATA ELEMENT NAME UNDEFINED - $.",
                       " BT/BD NOT FOUND.",
                       " DATA BLOCKS MISSING.",
                       " DATA FILE EMPTY.",
                       " DATA FILE CONTENT ERROR.",
                       " DATA FILE NOT AT BEGINNING OF FILE.",
                       " DATA FILE NOT IN CHRONOLOGICAL ORDER.",
                       " N EXCEEDS NUMBER OF FILES.",
                       " IN LESS THAN FILE WRITE TIME.",
                       " DATA FILE NOT FOUND - $.",
                       " DATA FILE POSITIONED AT EOI.",
                       " ACPD/CPD VERSIONS MISMATCH.",
                       " IN AND IC PARAMETER CONFLICT."];
 
        ITEM ER$ZR      C(03,48,02) = [0,0,0,0,0,0,0,0,0,0,0,0,0,0];
                                     # ZERO FILLED LAST BYTE #
        END  # ARRAY ERMS #
 
 
 
 
 
#
*     BEGIN PERROR PROC.
#
 
      IF (ERNM NQ 0)                 # NAME SPECIFIED #
      THEN
        BEGIN  # FILL IN ERROR NAME #
        SLOWFOR J=2 STEP 1 WHILE (C<J,1>ER$MS[ERCD] NQ DOLC)
        DO;                          # LOOK FOR DOLLAR SIGN #
 
        SLOWFOR L=0 STEP 1 WHILE (C<L,1>ERNM NQ 0)
          AND (C<L,1>ERNM NQ BLKC)
        DO
          BEGIN
          C<J,1>ER$MS[ERCD]=C<L,1>ERNM;
          J=J+1;
          END
 
        C<J,1>ER$MS[ERCD]=PRDC;
        END  # FILL IN ERROR NAME #
 
      MESSAGE(ER$MS[ERCD],3);        # ISSUE ERROR MESSAGE #
      IF (EROR NQ FATAL)
      THEN
        BEGIN
        RETURN;                      # TO CALLING PROGRAM #
        END
 
      ABORT;
      END  # PERROR #
 
      TERM
PROC PRDTEL((PVL),(DTY),(TMX));
# TITLE PRDTEL - PRINT ONE LINE OF DATA ELEMENT.  #
 
      BEGIN  # PRDTEL #
 
#
**    PRDTEL - PRINT ONE LINE OF DATA ELEMENT.
*
*     PRINT VALUES IN ONE LINE OF ONE DATA ELEMENT.
*
*     PROC PRDTEL((PVL),(DTY),(TMX))
*
*     ENTRY      PVL = POINTER TO VALUES.
*                DTY = DATA TYPE.
*                TMX = POINTER TO CURRENT TOTAL MAXIMUM AND
*                      MINIMUM VALUES.
*
*     EXIT       ONE ROW OF THE DATA ELEMENT-S VALUES ARE PRINTED.
*                THE SUBTOTAL IS ALSO PRINTED, ALONG WITH THE
*                MAXIMUM AND MIN VALUES OF THAT ROW.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM PVL        U;             # POINTER TO VALUES #
      ITEM DTY        I;             # DATA TYPE #
      ITEM TMX        U;             # POINTER TO TOTAL MAXIMUM VALUE #
 
#
****  PROC PRDTEL - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC DETMXM;                 # DETERMINE MAXIMUM AND MINIMUM #
        PROC WRITEV;                 # WRITE VALUE #
        END
 
#
****  PROC PRDTEL - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM CL         I;             # COLUMN #
      ITEM CR         I;             # CARRIAGE CONTROL #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM IC         I;             # INCREMENTOR #
      ITEM MN         I;             # MINIMUM INTERVAL #
      ITEM MX         I;             # MAXIMUM INTERVAL #
      ITEM X          R;             # TEMPORARY VARIABLE #
 
      BASED
      ARRAY MXN [0:0] S(2);          # TOTAL MAXIMUM/MINIMUM VALUES #
        BEGIN  # ARRAY MXN #
        ITEM MXN$MX     R(00,00,60);  # TOTAL MAXIMUM VALUE #
        ITEM MXN$MN     R(01,00,60);  # TOTAL MINIMUM VALUE #
        END  # ARRAY MXN #
 
      BASED
      ARRAY VAL [1:11] P(1);         # VALUES TO BE PRINTED #
        BEGIN  # ARRAY VAL #
        ITEM VL$F       R(00,00,60);  # REAL VALUE #
        ITEM VL$N       I(00,00,60);  # INTEGER VALUE #
        END  # ARRAY VAL #
 
 
 
 
 
#
*     BEGIN PRDTEL PROC.
#
 
      IF (NIPP LQ (DCDC-3))          # PRINT TOTAL ON SAME LINE #
      THEN                           # DO NOT LINE FEED #
        BEGIN
        CR=NLFC;
        END
 
      ELSE
        BEGIN
        CR=LFDC;                     # LINE FEED #
        END
 
#
*     DETERMINE MINIMUM AND MAXIMUM INTERVALS.
#
 
      P<VAL>=PVL;
      P<MXN>=TMX;
      MX=1;
      MN=1;
      FASTFOR I=1 STEP 1 UNTIL NIPP
      DO
        BEGIN  # FIND MAXIMUM AND MINIMUM COLUMNS #
        IF (VL$F[I] GR VL$F[MX])
        THEN
          BEGIN
          MX=I;                      # CURRENT MAXIMUM POSITION #
          END
 
        IF (VL$F[I] LS VL$F[MN])
        THEN
          BEGIN
          MN=I;                      # CURRENT MINIMUM POSITION #
          END
 
        END  # FIND MAXIMUM AND MINIMUM COLUMNS #
 
#
*     UPDATE CURRENT VALUES OF TOTAL MAXIMUM AND MINIMUM.
#
 
      IF (VL$F[MX] GR MXN$MX[0])     # INTERVAL MAXIMUM .GT.
                                       TOTAL MAXIMUM #
      THEN
        BEGIN
        MXN$MX[0]=VL$F[MX];          # UPDATE TOTAL MAXIMUM #
        END
 
      IF (VL$F[MN] LS MXN$MN[0])     # INTERVAL MINIMUM .LT.
                                       TOTAL MINIMUM #
      THEN
        BEGIN
        MXN$MN[0]=VL$F[MN];          # UPDATE TOTAL MINIMUM #
        END
 
      IF (DTY NQ FLPC)               # NOT FLOATING POINT #
      THEN                           # CONVERT VALUES TO INTEGER #
        BEGIN
        FASTFOR I=1 STEP 1 UNTIL NIPP+1
        DO
          BEGIN
          X=VL$F[I];
          VL$N[I]=X;
          END
 
        END
 
#
*     NOW PRINT THE VALUES IN ONE LINE STARTING FROM
*     COLUMN *BCLC*.
#
 
      CL=BCLC;
      FASTFOR I=1 STEP 1 UNTIL NIPP
      DO
        BEGIN
        WRITEV(VL$F[I],DTY,CL,10,NLFC);
        CL=CL+10;
        END
 
#
*     INDICATE MINIMUM AND MAXIMUM INTERVAL VALUES BY ENCLOSING
*     THEM IN PARENTHESES AND BRACKETS, RESPECTIVELY.
#
 
      IF (MX NQ MN)
      THEN
        BEGIN
        DETMXM(VL$F[MX],VL$F[MN],MX,MN,DTY);
        END
 
      IF (TCOL GR (DCDC-3))
      THEN
        BEGIN
        WRITEV(VL$F[NIPP+1],DTY,CL+1,9,CR);   # WRITE SUBTOTAL #
        END
 
      RETURN;
      END  # PRDTEL #
 
      TERM
PROC PUTBLK((NSF),(FWA),(LWA));
# TITLE PUTBLK - PRINT ELEMENTS OF ONE LOOP OF DATA BLOCK.  #
 
      BEGIN  # PUTBLK #
 
#
**    PUTBLK - PRINT ELEMENTS OF ONE LOOP OF DATA BLOCK.
*
*     PUTBLK IS THE DRIVER IN PRINTING THE DATA BLOCK ELMENTS
*     (FAST LOOP, MEDIUM LOOP, SLOW LOOP).
*
*     PROC PUTBLK((NSF),(FWA),(LWA))
*
*     ENTRY      NSF = NUMBER OF RECORDS PER INTERVAL.
*                FWA = FIRST WORD ADDRESS OF LOOP IN TABLE *DSPT*.
*                LWA = LAST WORD ADDRESS OF LOOP IN TABLE *DSPT*.
*
*     EXIT       DATA ELEMENTS OF ONE LOOP ARE PRINTED BY THE
*                ORDER SPECIFIED IN TABLE *DSPT*.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM NSF        I;             # NUMBER OF RECORDS PER INTERVAL #
      ITEM FWA        I;             # *FWA* OF BLOCK IN *DSPT* TABLE #
      ITEM LWA        I;             # *LWA* OF BLOCK IN *DSPT* TABLE #
 
#
****  PROC PUTBLK - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC DATELM;                 # PROCESS ONE DATA BLOCK ELEMENT #
        PROC GETMSG;                 # GET MESSAGE FROM *DSPTTXT* #
        PROC WRITEV;                 # WRITE DATA ELEMENT #
        END
 
#
****  PROC PUTBLK - XREF LIST END.
#
 
      DEF BLKC       #" "#;          # BLANK #
      DEF NSBC       #O"777"#;       # NO SUBBLOCK FLAG #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM CT         I;             # INDEX OF *DSPT* TABLE #
      ITEM FG         B;             # FLAG TO PRINT SUBBLOCK TITLE #
      ITEM FW         I;             # INDEX OF *DCDT* TABLE #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM IC         I;             # INCREMENTOR #
      ITEM J          I;             # INDEX #
      ITEM LN         I;             # LENGTH OF DATA ITEM #
      ITEM MS1        C(50);         # TEMPORARY BUFFER #
      ITEM POS        I;             # RELATIVE POSITION OF *WFP* #
      ITEM PT         I;             # INDEX OF *DDDT* TABLE #
      ITEM SM         I;             # SAMPLE TIMES #
      ITEM ST         I;             # POINTER TO SUBTABLE #
      ITEM SUM        I;             # SAMPLE TIMES SUBTOTAL #
      ITEM T          I;             # TEMPORARY STORAGE #
      ITEM TY         I;             # DATA TYPE #
      ITEM WA         I;             # WEIGHT FACTOR INFORMATION #
      ITEM WIC        I;             # INCREMENTOR OF WEIGHT FACTOR #
      ITEM WP         I;             # WEIGHT FACTOR #
 
      ARRAY MS2 [0:2] P(1);          # SUBBLOCK MESSAGE BUFFER #
        BEGIN  # ARRAY MS2 #
        ITEM MS2$MS     C(00,00,10)=[" "," "," "];  # MESSAGE BUFFER #
        END  # ARRAY MS2 #
 
 
 
 
 
#
*     BEGIN PUTBLK PROC.
#
 
      P<DCDT>=LOC(DBUF[DCHL]);
      P<DDSM>=LOC(DBUF[DCHL + DCDC*DCDL*2]);
      PT=DSPT$PT[FWA];               # POINTER TO *DDDT* #
      GETMSG(FWA,MS1);
      WRITEV(MS1,CHRC,1,22,NLFC);
 
#
*     PRINT SAMPLE TIMES. *NIPP* IS THE NUMBER OF COLUMNS PER PAGE.
#
 
      J=BCLC;                        # STARTING POSITION TO PRINT #
      SUM=0;
      P<DDSC>=LOC(DDDT);
 
      SLOWFOR I=1 STEP 1 UNTIL NIPP
      DO
        BEGIN
        SM=DCDT$WD[(I-1)*DCDL + DDSC$FW[PT]];
        WRITEV(SM,INTC,J,10,NLFC);
        SUM=SUM+SM;
        J=J+10;
        END
 
      IF (NIPP GR (DCDC-3))          # MORE THAN 7 COLUMNS #
      THEN                           # NO TOTAL ON THIS PAGE #
        BEGIN
        WRITEV(SUM,INTC,J,10,LFDC);  # PRINT SUBTOTAL #
        END
 
      ELSE                           # PRINT TOTAL ON SAME PAGE #
        BEGIN
        IF (NIPP GR 0)               # MORE THAN 1 COLUMN COLLECTED #
          AND (TCOL GR (DCDC-3))
        THEN                         # PRINT SUBTOTAL #
          BEGIN
          WRITEV(SUM,INTC,J,10,NLFC);
          J=J+10;
          END
 
        SUM=DDSM$IM[DDSC$FW[PT]];    # TOTAL SAMPLES #
        WRITEV(SUM,INTC,J,10,LFDC);
        END
 
#
*     COMPUTE AND PRINT LOOP ELEMENTS.
*     THE PROCESSING OF THE LOOP ELEMENTS WILL FOLLOW THE
*     INSTRUCTIONS CONTAINED IN THE *DSPT* TABLE FROM
*     *FWA* TO *LWA*.
#
 
      CT=FWA+1;
      FASTFOR I=0 WHILE (CT LQ LWA)
      DO
        BEGIN  # FOLLOW TABLE *DSPT* #
        PT=DSPT$PT[CT];              # POINTER TO *DDSC* TABLE #
        IF NOT (DDSC$SD[PT])         # ELEMENT IS NOT SELECTED #
        THEN
          BEGIN
          CT=CT+1;
          TEST I;                    # SKIP IT #
          END
 
        ST=DSPT$ST[CT];              # POINTER TO SUBTITLE TABLE #
        GETMSG(CT,MS1);
        WA=DDSC$WA[PT];              # WEIGHT FACTOR INFORMATION #
        WP=DDSC$WP[PT];              # WEIGHT FACTOR #
        IF (WA EQ WGFC)              # WEIGHT FACTOR SPECIFIED #
        THEN
          BEGIN  # CHECK IF MULTIPLE WEIGHT FACTORS #
          P<DDSC>=LOC(DDHD);
          IF (DDSC$LN[WP] GR 1)      # MORE THAN 1 WEIGHT FACTOR #
          THEN
            BEGIN
            WIC=DDSC$IC[WP];         # WEIGHT FACTOR INCREMENTOR #
            END
 
          ELSE
            BEGIN
            WIC=0;
            END
 
          P<DDSC>=LOC(DDDT);
          END  # CHECK IF MULTIPLE WEIGHT FACTORS #
 
        TY=DDSC$TY[PT];              # DATA TYPE #
        FW=DDSC$FW[PT];              # POINTER TO *DCDT* TABLE #
        LN=DDSC$LN[PT];              # NUMBER OF ENTRIES #
        IC=DDSC$IC[PT];              # INCREMENTOR #
 
#
*     IF THE POINTER TO SUBBLOCK TITLE TABLE *ST* IS NIL (*NSBC*),
*     THE ELEMENT IS A SINGLE ENTRY ELEMENT OR HAS NO SUBTITLES.
#
 
 
        IF (ST EQ NSBC)              # SINGLE ENTRY OR NO SUBTITLE #
        THEN
          BEGIN  # PROCESS SINGLE ENTRY OR NO SUBTITLE ELEMENT #
          FG=FALSE;                  # DO NOT PRINT SUBBLOCK TITLE #
          POS=0;                     # FIRST WEIGHT FACTOR POSITION #
          SLOWFOR J=1 STEP 1 WHILE (J LS LN)
          DO
            BEGIN
            DATELM(FG,BLKC,MS1,WA,WP,POS,TY,FW,NSF);
            CT=CT+1;
            GETMSG(CT,MS1);
            FW=FW+IC;
            POS=POS+WIC;
            END
 
          DATELM(FG,BLKC,MS1,WA,WP,POS,TY,FW,NSF);
          END  # PROCESS SINGLE ENTRY OR NO SUBTITLE ELEMENT #
 
#
*     THE ELEMENT HAS SUBTITLES TO BE PROCESS. EACH ENTRY OF THE
*     MULTIPLE-ENTRY ELEMENT HAS A SUBTITLE DEFINED IN TABLE *SMGT*.
#
 
        ELSE
          BEGIN  # MULTIPLE ENTRIES #
          T=ST;
          FG=TRUE;                   # PRINT SUBBLOCK #
          POS=0;
          FASTFOR J=1 STEP 1 UNTIL LN
          DO
            BEGIN  # PROCESS ONE ENTRY OF MULTIPLE-ENTRY ELEMENT #
            MS2$MS[1]=SMGT$TX[T];
            IF (MS2$MS[1] EQ BLKC)   # END OF SUBBLOCK TABLE #
            THEN
              BEGIN
              T=ST;                  # RESET *SMGT* POINTER #
              CT=CT+1;               # NEXT *DSPT* ELEMENT #
              GETMSG(CT,MS1);
              MS2$MS[1]=SMGT$TX[T];
              FG=TRUE;               # PRINT SUBBLOCK #
              END
 
            DATELM(FG,MS1,MS2,WA,WP,POS,TY,FW,NSF);
 
            T=T+1;
            FW=FW+IC;
            POS=POS+WIC;
            END  # PROCESS ONE ENTRY OF MULTIPLE-ENTRY ELEMENT #
 
          END  # MULTIPLE ENTRIES #
 
        CT=CT+1;
        END  # FOLLOW TABLE *DSPT* #
 
      END  # PUTBLK #
 
      TERM
PROC PUTDAT((NSF),(NIN));
# TITLE PUTDAT - PRINT DATA BLOCK ELEMENTS.  #
 
      BEGIN  # PUTDAT #
 
#
**    PUTDAT - PRINT DATA BLOCK ELEMENTS.
*
*     PRINT FAST, MEDIUM, SLOW, AND SNAPSHOT LOOPS.
*
*     PROC PUTDAT((NSF),(NIN))
*
*     ENTRY      NSF = NUMBER OF RECORDS PER INTERVAL.
*                NIN = NUMBER OF INTERVALS PER PAGE.
*                TABLE *DCDT* CONTAINS DATA BLOCK ELEMENT VALUES.
*
*     EXIT       DATA BLOCK ELEMENTS ARE PRINTED TO THE REPORT
*                FILE.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM NSF        I;             # NUMBER OF RECORDS PER INTERVAL #
      ITEM NIN        I;             # NUMBER OF INTERVALS PER PAGE #
 
#
****  PROC PUTDAT - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC PUTBLK;                 # PRINT ONE LOOP DATA ELEMENTS #
        PROC PUTSNS;                 # PRINT SNAPSHOT LOOP ELEMENTS #
        PROC RPEJECT;                # PAGE EJECT #
        PROC WRITEV;                 # WRITE DATA ELEMENT #
        END
 
#
****  PROC PUTDAT - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM FW         I;             # LOOP BEGINNING INDEX #
      ITEM LW         I;             # LOOP ENDING INDEX #
      ITEM MSG        C(30)="**********************";
                                     # LOOP REPORT SEPARATOR #
 
 
 
 
 
#
*     BEGIN PUTDAT PROC.
#
 
      NIPP=NIN;
      IF (P$L NQ NULL)               # REPORT FILE SPECIFIED #
      THEN
        BEGIN
        RPEJECT(OFFA);               # PAGE EJECT #
        END
 
      P<DCHD>=LOC(DBUF);
      P<DDSC>=LOC(DDHD);
 
      IF (DCHD$WD[DDSC$FW[DLIL]] NQ 0)  # FAST LOOP WAS COLLECTED #
      THEN
        BEGIN
        FW=HDML;
        LW=FW+FSML-1;
        PUTBLK(NSF,FW,LW);           # PROCESS FAST LOOP #
        WRITEV(MSG,CHRC,1,22,LFDC);
        END
 
      IF (DCHD$WD[DDSC$FW[DLML]] NQ 0)  # MEDIUM LOOP WAS COLLECTED #
      THEN
        BEGIN
        FW=HDML+FSML;
        LW=FW+MDML-1;
        PUTBLK(NSF,FW,LW);           # PROCESS MEDIUM LOOP #
        WRITEV(MSG,CHRC,1,22,LFDC);
        END
 
      IF (DCHD$WD[DDSC$FW[DLOL]] NQ 0)  # SLOW LOOP WAS COLLECTED #
      THEN
        BEGIN
        FW=HDML+FSML+MDML;
        LW=FW+SLML-1;
        PUTBLK(NSF,FW,LW);           # PROCESS SLOW LOOP #
        WRITEV(MSG,CHRC,1,22,LFDC);
        END
 
      IF (NIN GR 0)                  # NUMBER OF COLUMNS .GT. 0 #
        AND (DCHD$WD[DDSC$FW[DLFW]] NQ 0)  # SNAPSHOT WAS COLLECTED #
      THEN
        BEGIN
        FW=HDML+FSML+MDML+SLML;
        LW=FW+SNML-1;
        TLFG=2;
        PUTSNS(FW,LW);               # PROCESS SNAPSHOT LOOP ELEMENTS #
        TLFG=1;
        END
 
      RETURN;
      END  # PUTDAT #
 
      TERM
PROC PUTEST;
# TITLE PUTEST - PRINT *EST*.  #
 
      BEGIN  # PUTEST #
 
#
**    PUTEST - PRINT *EST*.
*
*     PRINT *EST* TABLE.
*
*     PROC PUTEST
*
*     ENTRY      TABLE *DCHD* CONTAINS HEADER BLOCK ELEMENT VALUES.
*
*     EXIT       EST IS WRITTEN TO THE REPORT FILE.
*
*     NOTE.
*
*     THE SYMBOL *SROS* DEFINED IN THIS ROUTINE HAS TO HAVE
*     THE SAME VALUE AS THE SYMBOL *SROS* DEFINED IN COMMON
*     DECK *COMSCPS*.
*     THE ITEMS *FATT* AND *FATL* HAVE TO BE CHANGED ACCORDINGLY
*     IF CHANGE IS MADE TO THE FILE TYPES.
#
 
#
****  PROC PUTEST - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC RPEJECT;                # PAGE EJECT #
        PROC WRITEV;                 # WRITE DATA ELEMENT #
        FUNC XCOD C(10);             # BINARY TO DISPLAY OCTAL #
        END
 
#
****  PROC PUTEST - XREF LIST END.
#
 
      DEF BLKC       #" "#;          # BLANK #
      DEF CHSC       #"S"#;          # CHARACTER S #
      DEF CHXC       #"X"#;          # CHARACTER X #
      DEF MGMC       #"MT"#;         # *MT* TAPE #
      DEF MGNC       #"NT"#;         # *NT* TAPE #
      DEF MNSC       #"-"#;          # MINUS SIGN #
      DEF MXMSA      #47#;           # MAXIMUM MS ALLOCATABLE DEVICE #
      DEF SROS       #8#;            # SECONDARY ROLLOUT DEVICE #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
*CALL     COMUEST
 
#
*     LOCAL VARIABLES.
#
 
      ITEM FATL       C(12)
         = "TIORDPLBSRRN";           # FILES TYPE #
      ITEM FATT       C(12);         # TEMPORARY BUFFER #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM J          I;             # FOR LOOP CONTROL #
      ITEM L          I;             # FOR LOOP CONTROL #
      ITEM M          I;             # TEMPORARY STORAGE #
      ITEM MSG        C(50);         # TEMPORARY BUFFER #
      ITEM MXRS       I;             # NUMBER OF *MSAL* CATEGORIES #
      ITEM MSI        I;             # MST ORDINAL #
      ITEM MSIC       I;             # MST INCREMENTOR #
      ITEM MUI        I;             # MST ORDINAL #
      ITEM MUIC       I;             # MST INCREMENTOR #
      ITEM N          I;             # TEMPORARY STORAGE #
 
      ARRAY CHNN [0:1] P(1);         # CHANNELS #
        BEGIN  # ARRAY CHNN #
        ITEM CH         U(00,00,60);  # CHANNEL WORD #
        ITEM CHAPFLAG   B(00,48,01);  # CHANNEL ACCESS PATH FLAG #
        ITEM CHSTATUS   U(00,49,02);  # CHANNEL STATUS #
        ITEM CHNUMBER   U(00,55,05);  # CHANNEL NUMBER #
        END  # ARRAY CHNN #
 
      ARRAY TEM [0:0] P(1);          # TEMPORARY BUFFER #
        BEGIN  # ARRAY TEM #
        ITEM TEM$TYPE   U(00,01,11);  # EQUIPMENT TYPE #
        END  # ARRAY TEM #
 
 
 
 
 
#
*     BEGIN PUTEST PROC.
#
 
      P<DCHD>=LOC(DBUF);
      P<DDSC>=LOC(DDHD);
 
      TLFG=3;                        # INDICATES PRINTING EST #
      RPEJECT(OFFA);
 
#
*     PRINT EST ENTRY.
#
 
      P<EST>=LOC(DCHD$WD[DDSC$FW[ESTB]]);
      MSI=0;
      MSIC=DDSC$IC[TRKC];
      MUI=0;
      MUIC=DDSC$IC[MSUN];
 
      SLOWFOR I=0 STEP 1 UNTIL DCHD$WD[DDSC$FW[ESTL]] - 1
      DO
        BEGIN  # PROCESS ONE EST ENTRY #
        IF (EST$EQDE[I] EQ NULL)     # ENTRY NOT DEFINED #
        THEN
          BEGIN
          TEST I;
          END
 
        WRITEV(I,OC2C,4,3,NLFC);     # EST ORDINAL #
        TEM$TYPE[0]=EST$TYPE[I];
        WRITEV(TEM,CHRC,11,2,NLFC);  # DEVICE TYPE #
 
        IF EST$STATUS[I] EQ 0        # ON DEVICE #
        THEN
          MSG="ON";
        ELSE
          BEGIN
          IF EST$STATUS[I] EQ 1      # IDLE DEVICE #
          THEN
            MSG="IDLE";
          ELSE
            BEGIN
            IF EST$STATUS[I] EQ 2    # OFF DEVICE #
            THEN
              MSG="OFF";
            ELSE                     # DOWN DEVICE #
              MSG="DOWN";
            END
 
          END
 
        WRITEV(MSG,CHRC,16,3,NLFC);  # DEVICE STATUS #
 
        IF (NOT EST$MS[I])           # NOT MASS STORAGE DEVICE #
        THEN
          BEGIN
          N=EST$EQU[I];
          WRITEV(N,OC2C,22,2,NLFC);  # EQUIPMENT NUMBER #
          N=EST$UN[I];
          WRITEV(N,OC2C,26,2,NLFC);  # UNIT NUMBER #
          END
 
        ELSE                         # MASS STORAGE DEVICE #
          BEGIN
          IF (EST$RMVE[I])           # REMOVABLE MASS STORAGE DEVICE #
          THEN
            BEGIN
            N=DCHD$WD[DDSC$FW[MSUN]+MUI];
            WRITEV(N,OC2C,26,2,NLFC);
            END
 
          MUI=MUI + MUIC;
          END
 
#
*     PRINT CHANNELS.
#
 
        CH[0]=EST$CHANA[I];          # CHANNEL A #
        CHAPFLAG[0]=EST$CHAAE[I];    # CHANNEL A ACCESS ENABLED FLAG #
        CHSTATUS[0]=EST$CHAST[I];    # CHANNEL A STATUS #
        CH[1]=EST$CHANB[I];          # CHANNEL B #
        CHAPFLAG[1]=EST$CHBAE[I];    # CHANNEL B ACCESS ENABLED FLAG #
        CHSTATUS[1]=EST$CHBST[I];    # CHANNEL B STATUS #
 
        FASTFOR L=0 STEP 1 UNTIL 1
        DO
          BEGIN  # PRINT CHANNEL NUMBER #
          IF (CHAPFLAG[L])           # CHANNEL ACCESS PATH ENABLED #
          THEN
            BEGIN
            IF (CHSTATUS[L] EQ 0)    # CHANNEL IS UP #
            THEN
              BEGIN
              WRITEV(CHNUMBER[L],OC2C,30+3*L,2,NLFC);
              END
 
            ELSE
              BEGIN
              WRITEV("**",CHRC,30+3*L,2,NLFC);
              END
 
            END
 
 
          END  # PRINT CHANNEL NUMBER #
 
#
*     PRINT EST ENTRY IN FULL WORD, AND DEVICE TRACK CAPACITY.
#
 
        N=EST$LHDE[I];
        WRITEV(N,OC3C,42,10,NLFC);
        N=EST$RHDE[I];
        WRITEV(N,OC3C,52,10,NLFC);
        N=EST$LHAE[I];
        WRITEV(N,OC3C,63,10,NLFC);
        N=EST$RHAE[I];
        IF (NOT EST$MS[I])           # NOT MASS STORAGE DEVICE #
        THEN
          BEGIN
          WRITEV(N,OC3C,73,10,LFDC);
          TEST I;
          END
 
        ELSE
          BEGIN  # MASS STORAGE DEVICE #
          WRITEV(N,OC3C,73,10,NLFC);
          N=DCHD$WD[DDSC$FW[TRKC] + MSI];
          WRITEV(N,OC2C,87,4,NLFC);  # TRACK CAPACITY #
          MSI=MSI+MSIC;
 
#
*     PRINT THE MASS STORAGE ALLOCATION TABLE.
#
 
          IF (I GR MXMSA)            # EST ORDINAL .GT. *MXMSA* #
          THEN
            BEGIN
            WRITEV(BLKC,CHRC,95,1,LFDC);  # LINE FEED #
            END
 
          ELSE                       # EST ORDINAL .LE. *MXMSA* #
            BEGIN  # CHECK FILE TYPE ON THE DEVICE #
            FATT="------------";
            MXRS=DCHD$WD[DDSC$FW[CON8]];
            SLOWFOR J=0 STEP 1 UNTIL MXRS-1
            DO
              BEGIN
              L=DDSC$FW[MSAA] + J;
              IF (B<12+I,1>DCHD$WD[L] EQ 1)
              THEN
                BEGIN
                C<J,1>FATT=C<J,1>FATL;
                END
 
              END
 
            IF (EST$SYS[I])          # SYSTEM FILE ON DEVICE #
            THEN
              BEGIN
              MSG=CHXC;
              END
 
            ELSE
              BEGIN
              MSG=MNSC;
              END
 
            WRITEV(MSG,CHRC,94,1,NLFC);
 
#
*     PRINT THE THRESHOLD OF THE NUMBER OF SECTORS ROLLED IF
*     THE DEVICE IS SECONDARY ROLLOUT.
#
 
            IF (C<SROS,1>FATT NQ CHSC)  # NOT SECONDARY ROLLOUT #
            THEN
              BEGIN
              WRITEV(FATT,CHRC,95,MXRS,LFDC);
              END
 
            ELSE                     # SECONDARY ROLLOUT #
              BEGIN
              WRITEV(FATT,CHRC,95,MXRS,NLFC);
              WRITEV("THRESHOLD = ",CHRC,109,12,NLFC);
              WRITEV(DCHD$WD[DDSC$FW[SROT]],OC1C,121,5,NLFC);
              WRITEV("SECTORS",CHRC,127,7,LFDC);
              END
 
            END  # CHECK FILE TYPE ON THE DEVICE #
 
          END  # MASS STORAGE DEVICE #
 
        END  # PROCESS ONE EST ENTRY #
 
      RETURN;
      END  # PUTEST #
 
      TERM
PROC PUTHDR;
# TITLE PUTHDR - PROCESS HEADER BLOCK.  #
 
      BEGIN  # PUTHDR #
 
#
**    PUTHDR - PROCESS HEADER BLOCK.
*
*     PRINT FIRST PAGE OF HEADER BLOCK ELEMENTS.
*
*     PROC HEADER
*
*     ENTRY      TABLE *DCHD* CONTAINS HEADER BLOCK ELEMENT VALUES.
*
*     EXIT       HEADER BLOCK ELEMENTS ARE PRINTED TO THE REPORT
*                FILE.
#
 
#
****  PROC PUTHDR - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC HDRELM;                 # PROCESS HEADER BLOCK ELEMENT #
        PROC RPEJECT;                # PAGE EJECT #
        PROC RPSPACE;                # LINE FEED #
        PROC WRITEV;                 # WRITE ONE ELEMENT #
        END
 
#
****  PROC PUTHDR - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM MSG        C(50);         # TEMPORARY BUFFER #
 
 
 
 
 
#
*     BEGIN PUTHDR PROC.
#
 
      TLFG=0;                        # INDICATES NO SUBTITLE #
      RPEJECT(OFFA);
      RPSPACE(OFFA,2,1);
 
#
*     PRINT START DATE AND START TIME OF THE DATA FILE.
#
 
      HDRELM(0,11,34);               # START DATE #
      HDRELM(1,11,34);               # START TIME #
 
#
*     PRINT *ACPD* PARAMETERS.
#
 
      RPSPACE(OFFA,2,1);
      WRITEV("DATA FILE NAME",CHRC,11,14,NLFC);
      WRITEV(P$FN,CHRC,40,7,LFDC);
      IF (P$IN NQ 0)
      THEN
        BEGIN
        WRITEV("REPORT INTERVAL (MINUTES)",CHRC,11,25,NLFC);
        WRITEV(P$IN,INTC,37,10,LFDC);
        END
 
      ELSE
        BEGIN
        WRITEV("REPORT INTERVAL (RECORDS)",CHRC,11,25,NLFC);
        WRITEV(P$IC,INTC,37,10,LFDC);
        END
 
      RPSPACE(OFFA,2,1);
      FASTFOR I=APPM STEP 1 UNTIL HWCF-1
      DO
        BEGIN
        HDRELM(I,11,40);
        END
 
#
*     PRINT THE HARDWARE CONFIGURATION.
#
 
      RPSPACE(OFFA,2,1);
      FASTFOR I=HWCF STEP 1 UNTIL CMCF-1
      DO
        BEGIN
        HDRELM(I,11,40);
        END
 
#
*     PRINT THE CMR CONFIGURATION.
#
 
      RPSPACE(OFFA,2,1);
      FASTFOR I=CMCF STEP 1 UNTIL SASC-1
      DO
        BEGIN
        HDRELM(I,11,40);
        END
 
#
*     PRINT THE SYSTEM ASSEMBLY CONSTANTS.
#
 
      RPSPACE(OFFA,2,1);
      FASTFOR I=SASC STEP 1 UNTIL SDLP-1
      DO
        BEGIN
        HDRELM(I,11,47);
        END
 
#
*     PRINT THE SYSTEM DELAY PARAMETERS.
#
 
      RPSPACE(OFFA,2,1);
      FASTFOR I=SDLP STEP 1 UNTIL BFIO-1
      DO
        BEGIN
        HDRELM(I,11,47);
        END
 
#
*     PRINT THE TOTAL NUMBER OF HIGH SPEED DISK BUFFERS
*     AND EXTENDED MEMORY/PP BUFFERS.
#
 
      RPSPACE(OFFA,2,1);
      FASTFOR I=BFIO STEP 1 UNTIL HDML-1
      DO
        BEGIN
        HDRELM(I,11,47);
        END
 
      RETURN;
      END  # PUTHDR #
 
      TERM
PROC PUTSCI;
# TITLE PUTSCI - PRINT SYSTEM CONTROL INFORMATION.  #
 
      BEGIN  # PUTSCI #
 
#
**    PUTSCI - PRINT SYSTEM CONTROL INFORMATION.
*
*     PRINT SYSTEM CONTROL INFORMATION.
*
*     PROC PUTSCI
*
*     ENTRY      TABLE *DCHD* CONTAINS HEADER BLOCK ELEMENT VALUES.
*
*     EXIT       SYSTEM CONTROL INFORMATION (SERVICE CLASSES,
*                PRIORITY, ETC.) ARE PRINTED TO THE REPORT FILE.
#
 
#
****  PROC PUTSCI - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC RPEJECT;                # PAGE EJECT #
        PROC RPSPACE;                # LINE FEED #
        PROC WRITEV;                 # WRITE DATA ELEMENT #
        END
 
#
****  PROC PUTSCI - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
*CALL     COMUJCA
 
#
*     LOCAL VARIABLES.
#
 
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM VALUE      I;             # TEMPORARY STORAGE #
 
 
 
 
 
#
*     BEGIN PUTSCI PROC.
#
 
      TLFG=0;                        # INDICATES NO SUBTITLE #
      P<DCHD>=LOC(DBUF);
      P<DDSC>=LOC(DDHD);
 
      RPEJECT(OFFA);
      RPSPACE(OFFA,2,1);
      WRITEV("SYSTEM CONTROL INFORMATION",CHRC,11,26,LFDC);
 
      RPSPACE(OFFA,2,1);
      WRITEV("SERVICE   QUEUE",CHRC,11,15,NLFC);
      WRITEV("               PRIORITIES",CHRC,26,25,NLFC);
      WRITEV("SERVICE LIMITS",CHRC,77,14,LFDC);
 
      WRITEV("CLASS",CHRC,11,5,NLFC);
      WRITEV("CP      CT    CM     NJ    TD",CHRC,69,29,LFDC);
 
      WRITEV("FL      AM    TP     AJ    DT",CHRC,69,29,LFDC);
 
      WRITEV("IL     LP     UP    WF    IP",CHRC,31,28,NLFC);
      WRITEV("EC      EM    DS   FC  CS  FS",CHRC,69,29,LFDC);
 
      WRITEV("PR      SE    RS     US",CHRC,69,23,LFDC);
 
      P<JBCA>=LOC(DCHD$WD[DDSC$FW[JCBA]]);
 
#
*     PRINT SERVICE CLASS INFORMATION.
#
 
      SLOWFOR I=1 STEP 1 UNTIL DCHD$WD[DDSC$FW[MXNS]]-2
      DO
        BEGIN  # PROCESS ONE SERVICE CLASS #
        RPSPACE(OFFA,2,1);
        WRITEV(JCST$SC[I],CHRC,13,2,NLFC);  # SERVICE CLASS NAME #
        WRITEV("IN",CHRC,22,2,NLFC);
        WRITEV(JCA$INLP[I],OC2C,36,4,NLFC);
        WRITEV(JCA$INUP[I],OC2C,43,4,NLFC);
        VALUE=2**JCA$INWF[I];
        WRITEV(VALUE,OC2C,49,4,NLFC);
        WRITEV(JCA$CP[I],OC2C,67,4,NLFC);
        WRITEV(JCA$CT[I],OC2C,75,4,NLFC);
        WRITEV(JCA$CM[I],OC2C,81,4,NLFC);
        WRITEV(JCA$NJ[I],OC2C,88,4,NLFC);
        WRITEV(JCA$TD[I],OC2C,94,4,LFDC);
 
        WRITEV("EX",CHRC,22,2,NLFC);
        WRITEV(JCA$EXIL[I],OC2C,29,4,NLFC);
        WRITEV(JCA$EXLP[I],OC2C,36,4,NLFC);
        WRITEV(JCA$EXUP[I],OC2C,43,4,NLFC);
        VALUE=2**JCA$EXWF[I];
        WRITEV(VALUE,OC2C,49,4,NLFC);
        WRITEV(JCA$EXIP[I],OC2C,55,4,NLFC);
        WRITEV(JCA$FL[I],OC2C,67,4,NLFC);
        WRITEV(JCA$AM[I],OC2C,71,8,NLFC);
        WRITEV(JCA$TP[I],OC2C,81,4,NLFC);
        WRITEV(JCA$AJ[I],OC2C,88,4,NLFC);
        WRITEV(JCST$SC[JCA$DT[I]],CHRC,96,2,LFDC);
 
        WRITEV("OT",CHRC,22,2,NLFC);
        WRITEV(JCA$OTLP[I],OC2C,36,4,NLFC);
        WRITEV(JCA$OTUP[I],OC2C,43,4,NLFC);
        VALUE=2**JCA$OTWF[I];
        WRITEV(VALUE,OC2C,49,4,NLFC);
        WRITEV(JCA$EC[I],OC2C,67,4,NLFC);
        WRITEV(JCA$EM[I],OC2C,75,4,NLFC);
        WRITEV(JCA$DS[I],OC2C,84,1,NLFC);
        WRITEV(JCA$FC[I],OC2C,89,1,NLFC);
        WRITEV(JCA$CS[I],OC2C,93,1,NLFC);
        WRITEV(JCA$FS[I],OC2C,97,1,LFDC);
 
        WRITEV(JCA$PR[I],OC2C,67,4,NLFC);
        WRITEV(JCA$SE[I],OC2C,75,4,NLFC);
        WRITEV(JCA$RS[I],OC2C,81,4,NLFC);
        WRITEV(JCA$US[I],OC2C,88,4,LFDC);
 
        END  # PROCESS ONE SERVICE CLASS #
 
      RETURN;
      END  # PUTSCI #
 
      TERM
PROC PUTSNS((FWA),(LWA));
# TITLE PUTSNS - PROCESS SNAPSHOT LOOP ELEMENTS.  #
 
      BEGIN  # PUTSNS #
 
#
**    PUTSNS - PROCESS SNAPSHOT LOOP ELEMENTS.
*
*     PUTSNS IS THE DRIVER OF THE SNAPSHOT LOOP ELEMENTS.
*
*     PROC PUTSNS((FWA),(LWA))
*
*     ENTRY      FWA = FIRST WORD ADDRESS OF SNAPSHOT LOOP
*                      ELEMENTS IN TABLE *DSPT*.
*                LWA = LAST WORD ADDRESS OF SNAPSHOT LOOP
*                      ELEMENTS IN TABLE *DSPT*.
*
*     EXIT       SNAPSHOT LOOP ELEMENTS ARE PRINTED TO THE REPORT
*                FILE.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM FWA        I;             # *FWA* IN *DSPT* TABLE #
      ITEM LWA        I;             # *LWA* IN *DSPT* TABLE #
 
#
****  PROC PUTSNS - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC GETMSG;                 # GET TITLE FROM TABLE *DSPTTXT* #
        PROC WRITEV;                 # WRITE DATA ELEMENT #
        END
 
#
**** PROC PUTSNS - XREF LIST END.
#
 
      DEF BLKC       #" "#;          # BLANK #
      DEF BPCC       #6#;            # NUMBER OF BITS PER CHAR #
      DEF NSBC       #O"777"#;       # NO SUBBLOCK FLAG #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM BL         U;             # BIT LENGTH #
      ITEM BT         I;             # BIT POSITION #
      ITEM FW         I;             # POINTER TO *DCDT* TABLE #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM IC         I;             # INCREMENTOR #
      ITEM J          I;             # FOR LOOP CONTROL #
      ITEM K          I;             # FOR LOOP CONTROL #
      ITEM L          I;             # FOR LOOP CONTROL #
      ITEM LN         U;             # TITLE LENGTH IN CHARACTERS #
      ITEM MSG        C(50);         # TEMPORARY BUFFER #
      ITEM N          I;             # TEMPORARY STORAGE #
      ITEM PT         I;             # POINTER TO *DDDT* TABLE #
      ITEM ST         U;             # POINTER TO SUBTITLE TABLE #
      ITEM VL         I;             # TEMPORARY VALUE #
      ITEM WC         I;             # WORD COUNT #
 
 
 
 
 
 
#
*     BEGIN PUTSNS PROC.
#
 
      P<DCDT>=LOC(DBUF[DCHL]);
      P<DDSC>=LOC(DDDT);
 
      FASTFOR I=FWA STEP 1 UNTIL LWA
      DO
        BEGIN  # FOLLOW TABLE *DSPT* #
        PT=DSPT$PT[I];               # POINTER TO *DDSC* #
        ST=DSPT$ST[I];               # POINTER TO *SMGT* #
        BL=DSPT$BL[I];               # BIT LENGTH #
        LN=DSPT$LN[I];
        GETMSG(I,MSG);
        FW=DDSC$FW[PT];
        IC=DDSC$IC[PT];              # INCREMENTOR #
 
#
*     IF BIT LENGTH *BL* IS ZERO, THE VALUE IS A FULL WORD VALUE.
*     THE VALUE IS PRINTED IN FIVE 12-BIT BYTES, IN SUCCESSIVE ROWS.
#
 
        IF (BL EQ 0)                 # NO BIT LENGTH #
        THEN
          BEGIN  # ACCESS FULL WORD #
          WRITEV(MSG,CHRC,1,LN,LFDC);
          FASTFOR J=1 STEP 1 UNTIL DDSC$LN[PT]
          DO
            BEGIN  # PROCESS ONE ENTRY #
            IF (ST NQ NSBC)          # SUBTITLE PRESENT #
            THEN                     # PRINT SUBTITLE #
              BEGIN
              MSG=SMGT$TX[ST+J-1];
              WRITEV(MSG,CHRC,10,10,NLFC);
              END
 
            FASTFOR L=0 STEP 1 UNTIL 4
            DO
              BEGIN  # BREAK A WORD INTO FIVE BYTES #
              N=31;
              SLOWFOR K=1 STEP 1 UNTIL NIPP
              DO                     # PRINT BYTE L OF COLUMN K #
                BEGIN
                VL=C<L*2,2>DCDT$CW[(K-1)*DCDL + FW];
                WRITEV(VL,OC3C,N,4,NLFC);
                N=N+10;
                END
 
              WRITEV(BLKC,CHRC,N+2,1,LFDC);  # LINE FEED #
              END  # BREAK A WORD INTO FIVE BYTES #
 
            FW=FW+IC;
            END  # PROCESS ONE ENTRY #
 
          END  # ACCESS FULL WORD #
 
#
*     IF BIT LENGTH *BL* IS NON ZERO, THE VALUE IS A PARTIAL WORD
*     VALUE. *WC* IS THE WORD COUNT INDICATING WHAT WORD IN A
*     MULTIPLE-ENTRY ELEMENT THAT CONTAINS THE VALUE. IF THE ELEMENT
*     IS A SINGLE-ENTRY ELEMENT, *WC* IS ZERO. *BL* AND *BT* ARE
*     THE NUMBER OF BITS AND THE STARTING BIT POSITION, RESPECTIVELY.
#
 
        ELSE
          BEGIN  # ACCESS PARTIAL WORD #
          WRITEV(MSG,CHRC,1,LN,NLFC);
          BT=DSPT$BT[I]/BPCC;        # CHARACTER POSITION #
          WC=DSPT$WC[I];             # WORD POSITION #
          BL=BL/BPCC;                # NUMBER OF CHARACTERS #
          N=BCLC + 2;
 
          SLOWFOR J=1 STEP 1 UNTIL NIPP
          DO
            BEGIN
            VL=C<BT,BL>DCDT$CW[(J-1)*DCDL + FW + WC];
            WRITEV(VL,INTC,N,8,NLFC);
            N=N+10;
            END
 
          WRITEV(BLKC,CHRC,N+2,1,LFDC);  # LINE FEED #
          END  # ACCESS PARTIAL WORD #
 
        END  # FOLLOW TABLE *DSPT* #
 
      RETURN;
      END  # PUTSNS #
 
      TERM
PROC READRC(STAT);
# TITLE READRC - READ DATA FILE.  #
 
      BEGIN  # READRC #
 
#
**    READRC - READ DATA FILE.
*
*     READ ONE RECORD FROM THE DATA FILE.
*
*     PROC READRC(STAT)
*
*     ENTRY      THE DATA FILE.
*
*     EXIT       STAT = STATUS CODE.
*                ONE RECORD OF THE DATA FILE IS READ TO
*                WORKING STORAGE AREA *WSAI*.
*                THE NUMBER OF WORDS READ *IBNW* IS UPDATED.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM STAT       I;             # STATUS CODE #
 
#
****  PROC READRC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC READSKP;                # READ AND SKIP #
        END
 
#
****  PROC READRC - XREF LIST END.
#
 
      DEF RFETL      #8#;            # FET LENGTH #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMAFET
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ARRAY STT [0:0] P(1);          # STATUS CODE #
        BEGIN  # ARRAY STT #
        ITEM STT$STAT   U(00,42,18);  # STATUS #
        ITEM STT$LN     U(00,42,04);  # LEVEL NUMBER #
        ITEM STT$AT     U(00,46,04);  # ABNORMAL TERMINATION CODE #
        ITEM STT$CODE   U(00,50,10);  # REQUEST/RETURN CODE #
        END  # ARRAY STT #
 
 
 
 
#
*     BEGIN READRC PROC.
#
 
      P<FETSET>=LOC(FETI);
      FET$IN[0]=FET$FRST[0];         # SET *IN* = *FIRST* #
      FET$OUT[0]=FET$FRST[0];        # SET *OUT* = *FIRST* #
      READSKP(FETSET,0,1);
      IBNW = FET$IN[0] - FET$OUT[0];  # NUMBER OF WORDS READ #
      STT$LN[0]=FET$LN[0];
      STT$AT[0]=FET$AT[0];
      STT$CODE[0]=FET$CODE[0];
 
      STAT=STT$STAT[0];
      RETURN;
      END  # READRC #
 
      TERM
PROC REPTLE;
# TITLE REPTLE - PRINT REPORT SUBTITLE.  #
 
      BEGIN  # REPTLE #
 
#
**    REPTLE - PRINT REPORT SUBTITLE.
*
*     *REPTLE* PRINTS THE SUBTITLE AT EACH PAGE EJECT.
*     THE SUBTITLE TO BE PRINTED DEPENDS ON THE VALUE
*     OF *TLFG* (COMMON BLOCK *CIOCOMM*).
*
*     PROC REPTLE
*
*     ENTRY      NIPP = NUMBER OF INTERVALS PER PAGE
*                       (COMMON BLOCK *CIOCOMM*).
*                TLFG = SUBTITLE FLAG (COMMON BLOCK *CIOCOMM*).
*                       IF *TLFG* IS :
*                       0    NO SUBTITLE.
*                       1    PRINT SUBTITLE FOR DATA BLOCK.
*                       2    PRINT SUBTITLE FOR SNAPSHOT.
*                       3    PRINT SUBTITLE FOR EST REPORT.
*
*     EXIT       SUBTITLE IS PRINTED ON TOP OF EACH PAGE.
#
 
#
****  PROC REPTLE - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        FUNC EDATE C(10);            # CONVERT NUMBER TO DATE #
        FUNC ETIME C(10);            # CONVERT NUMBER TO TIME #
        PROC RPLINEX;                # PRINT ONE LINE #
        FUNC XCDD C(10);             # CONVERT TO DISPLAY DECIMAL #
        END
 
#
****  PROC REPTLE - XREF LIST END.
#
 
      DEF ASTC       #"*"#;          # ASTERISK #
      DEF BLKC       #" "#;          # BLANK #
      DEF PRDC       #"."#;          # PERIOD #
      DEF SLSC       #"/"#;          # SLASH #
      DEF ZERC       #"0"#;          # CHARACTER ZERO #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM ESTFS      B=TRUE;        # FIRST EST SUBTITLE FLAG #
      ITEM HRS        I;             # HOUR #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM J          I;             # TEMPORARY VARIABLE #
      ITEM MNS        I;             # MINUTE #
      ITEM MSG        C(40);         # TEMPORARY STORAGE #
      ITEM N          I;             # TEMPORARY VARIABLE #
      ITEM N1         I;             # TEMPORARY VARIABLE #
      ITEM N2         I;             # TEMPORARY VARIABLE #
      ITEM OF         I;             # OFFSET #
 
      ARRAY T [0:0] P(1);            # TEMPORARY STORAGE #
        BEGIN
        ITEM T$WD       C(00,00,10);  # TEN CHARACTER WORD #
        ITEM T$3C       C(00,00,03);  # THREE CHARACTER ITEM #
        ITEM T$2C       C(00,00,02);  # TWO CHARACTER ITEM #
        ITEM T$1C       C(00,00,01);  # ONE CHARACTER ITEM #
        ITEM T$ZC       C(00,06,01);  # ZERO FILL #
        END
 
      ARRAY TEM [0:0] P(1);          # TEMPORARY STORAGE #
        BEGIN  # ARRAY TEM #
        ITEM TEM$WD     C(00,00,10);  # TEN CHARACTER ITEM #
        ITEM TEM$3C     C(00,42,03);  # THREE CHARACTER ITEM #
        ITEM TEM$2C     C(00,48,02);  # TWO CHARACTER ITEM #
        END
 
 
 
 
 
 
#
*     BEGIN REPTLE PROC.
#
 
      IF (TLFG EQ 0) OR (P$L EQ NULL)   # NO TITLE OR NO REPORT FILE #
      THEN
        BEGIN
        RETURN;                      # NO SUBTITLE #
        END
 
      IF (TLFG EQ 3)                 # PRINTING EST #
      THEN
        BEGIN  # PRINT EST SUBTITLE #
        RPLINEX(OFFA,BLKC,1,1,LFDC);
        RPLINEX(OFFA,BLKC,1,1,LFDC);
        IF (ESTFS)                   # FIRST EST SUBTITLE #
        THEN
          BEGIN
          MSG="EQUIPMENT STATUS TABLE";
          RPLINEX(OFFA,MSG,5,22,LFDC);
          ESTFS=FALSE;
          END
 
        ELSE                         # SECOND EST SUBTITLE #
          BEGIN
          MSG="EQUIPMENT STATUS TABLE  (CONTINUED)";
          RPLINEX(OFFA,MSG,5,35,LFDC);
          END
 
        MSG="NO.  TYPE  STAT  EQ  UN  CHANNELS";
        RPLINEX(OFFA,MSG,5,33,NLFC);
        MSG="EST ENTRY";
        RPLINEX(OFFA,MSG,42,9,NLFC);
        MSG="TRACK       FILES";
        RPLINEX(OFFA,MSG,86,17,LFDC);
        RPLINEX(OFFA,BLKC,1,1,LFDC);
        RETURN;
        END  # PRINT EST SUBTITLE #
 
      P<DCDT>=LOC(DBUF[DCHL]);
      P<DDSM>=LOC(DBUF[DCHL + DCDC*DCDL*2]);
      P<DDSC>=LOC(DDDT);
 
#
*     PRINT INTERVAL TIMES.
#
 
      RPLINEX(OFFA,BLKC,1,1,LFDC);   # LINE FEED #
      IF(P$IN NQ 0)
      THEN
        BEGIN
        TEM$WD=XCDD(P$IN);
        END
 
      ELSE
        BEGIN
        TEM$WD=XCDD(P$IC);
        END
 
      T$3C[0]=TEM$3C[0];
      RPLINEX(OFFA,T,1,3,NLFC);
      IF (P$IN NQ 0)                 # INTERVAL TIME SPECIFIED #
      THEN
        BEGIN
        RPLINEX(OFFA," MINS INTERVAL ",5,14,NLFC);
        END
 
      ELSE
        BEGIN
        RPLINEX(OFFA," RECS INTERVAL ",5,14,NLFC);
        END
 
      J = BCLC + 1;
      OF=DCDC*DCDL + DDSC$FW[PDTM];
 
      SLOWFOR I=1 STEP 1 UNTIL NIPP
      DO
        BEGIN  # PRINT INTERVAL TIME #
        N=DCDT$ET[(I-1)*DCDL + OF];  # INTERVAL END TIME #
        T$WD[0]=ETIME(N);            # CONVERT TO DISPLAY TIME #
        RPLINEX(OFFA,T,J,9,NLFC);
        J=J+10;
        END  # PRINT INTERVAL TIME #
 
#
*     PRINT TITLES OF SUBTOTAL AND TOTAL. IF SNAPSHOT
*     LOOP IS BEING PRINTED, THESE TITLES WILL NOT BE
*     PRINTED.
#
 
      IF (TLFG EQ 1)                 # NOT PRINTING SNAPSHOT ELEMENTS #
      THEN
        BEGIN  # PRINT TIME #
 
#
*     PRINT SUBTOTAL HEADER. SUBTOTAL IS NOT PRINTED IF THE SUBTOTAL
*     AND THE TOTAL COLUMNS ARE THE SAME, I.E. IF THE TOTAL COLUMNS
*     PRINTED *TCOL* IS LESS THAN 7 COLUMNS. THE SUBTOTAL HEADER IS
*     NOT PRINTED IF THE CURRENT PAGE IS USED TO PRINT THE TOTAL
*     STATISTICS ONLY (*NIPP* IS 0).
#
 
        IF (NIPP GR 0) AND (TCOL GR (DCDC-3))
        THEN
          BEGIN  # COMPUTE AND PRINT LENGTH OF SUBTOTAL #
          N=P$IN*NIPP;               # LENGTH OF SUBTOTAL #
          HRS=N/60;                  # NUMBER OF HOURS #
          MNS=N - (HRS*60);          # NUMBER OF MINUTES #
          TEM$WD=XCDD(HRS);
          T$3C[0]=TEM$3C[0];
          IF (T$2C[0] EQ BLKC)
          THEN
            BEGIN
            T$ZC[0]=ZERC;
            END
 
          RPLINEX(OFFA,T,J,3,NLFC);
          RPLINEX(OFFA,":",J+3,1,NLFC);
          TEM$WD=XCDD(MNS);
          T$2C[0]=TEM$2C[0];
          IF (T$1C[0] EQ BLKC)
          THEN
            BEGIN
            T$1C[0]=ZERC;
            END
 
          RPLINEX(OFFA,T,J+4,2,NLFC);
          END  # COMPUTE AND PRINT LENGTH OF SUBTOTAL #
 
#
*     PRINT TOTAL HEADER. TOTAL HEADER IS NOT PRINTED IF MORE
*     THAN 7 COLUMNS ARE PRINTED ON THE CURRENT PAGE.
#
 
        IF (NIPP GR (DCDC-3))
        THEN
          BEGIN
          RPLINEX(OFFA," HR",J+6,3,LFDC);
          END
 
        ELSE
          BEGIN  # COMPUTE AND PRINT LENGTH OF TOTAL #
          IF (NIPP GR 0) AND (TCOL GR (DCDC-3))
          THEN
            BEGIN
            RPLINEX(OFFA," HR",J+6,3,NLFC);
            J=J+10;
            END
 
          P<DCHD>=LOC(DBUF);
          P<DDSC>=LOC(DDHD);
          N=(DCHD$WD[DDSC$FW[DLFW]]*ACNS)/60;  # TOTAL MINUTES #
          HRS=N/60;                  # TOTAL HOURS #
          MNS=N - (HRS*60);
          TEM$WD[0]=XCDD(HRS);
          T$3C[0]=TEM$3C[0];
          IF (T$2C[0] EQ BLKC)
          THEN
            BEGIN
            T$ZC[0]=ZERC;
            END
 
          RPLINEX(OFFA,T,J,3,NLFC);
          RPLINEX(OFFA,":",J+3,1,NLFC);
          TEM$WD[0]=XCDD(MNS);
          T$2C[0]=TEM$2C[0];
          IF (T$1C[0] EQ BLKC)
          THEN
            BEGIN
            T$1C[0]=ZERC;
            END
 
          RPLINEX(OFFA,T,J+4,2,NLFC);
          RPLINEX(OFFA," HR",J+6,3,NLFC);
 
#
*     PRINT HEADERS FOR THE MAXIMUM AND MINIMUM STATISTIC COLUMNS.
#
 
          P<DDSC>=LOC(DDDT);
          N1=DDSM$BT[DDSC$FW[PDTM]];   # TOTAL BEGIN TIME #
          N2=DDSM$ET[DDSC$FW[PDTM]];   # TOTAL END TIME #
          T$WD[0]=EDATE(N1/SHFC);    # CONVERT TO DATE #
          RPLINEX(OFFA,T,J+11,9,NLFC);
          RPLINEX(OFFA,"TO ",J+21,3,NLFC);
          T$WD[0]=EDATE(N2/SHFC);
          RPLINEX(OFFA,T,J+23,9,LFDC);
          END  # COMPUTE AND PRINT LENGTH OF TOTAL #
 
        END  # PRINT TIME #
 
      ELSE                           # PRINTING SNAPSHOT ELEMENTS #
        BEGIN
        RPLINEX(OFFA,BLKC,J,1,LFDC);
        END
 
#
*     PRINT SECOND LINE OF THE SUBTITLE.
#
 
      J=BCLC + 1;
      SLOWFOR I=1 STEP 1 UNTIL NIPP
      DO
        BEGIN
        RPLINEX(OFFA," INTERVAL",J,9,NLFC);
        J=J+10;
        END
 
      IF (TLFG EQ 1)                 # NOT PRINTING SNAPSHOT ELEMENTS #
      THEN
        BEGIN  # PRINT SUBTOTAL AND TOTAL HEADERS #
        IF (NIPP GR (DCDC-3))
        THEN                         # PRINT TOTAL ON NEXT PAGE #
          BEGIN
          RPLINEX(OFFA," SUBTOTAL",J,9,LFDC);
          END
 
        ELSE                         # PRINT TOTAL ON THE SAME PAGE #
          BEGIN  # PRINT SUBTOTAL AND TOTAL HEADERS ON SAME PAGE #
          IF (NIPP GR 0)             # TOTAL IS NOT FIRST COLUMN #
            AND (TCOL GR (DCDC-3))
          THEN
            BEGIN
            RPLINEX(OFFA," SUBTOTAL",J,9,NLFC);
            J=J+10;
            END
 
          RPLINEX(OFFA,"    TOTAL",J,9,NLFC);
          RPLINEX(OFFA,"    *MAX* ",J+10,10,NLFC);
          RPLINEX(OFFA,"    *MIN* ",J+20,10,LFDC);
          END  # PRINT SUBTOTAL AND TOTAL HEADERS ON SAME PAGE #
 
        END  # PRINT SUBTOTAL AND TOTAL HEADERS #
 
      ELSE                           # PRINTING SNAPSHOT ELEMENTS #
        BEGIN
        RPLINEX(OFFA,BLKC,J,1,LFDC);
        END
 
      RPLINEX(OFFA,BLKC,1,1,LFDC);   # LINE FEED #
      RETURN;
      END  # REPTLE #
 
      TERM
PROC WRITEV(PVL,(DTY),(BCL),(FWD),(CRC));
# TITLE WRITEV - WRITE TO REPORT FILE.  #
 
      BEGIN  # WRITEV #
 
#
**    WRITEV - WRITE TO REPORT FILE.
*
*     WRITE ONE VALUE TO THE REPORT FILE.
*
*     PROC WRITEV(PVL,(DTY),(BCL),(FWD),(CRC))
*
*     ENTRY      PVL = VALUE TO BE PRINTED.
*                DTY = DATA TYPE.
*                BCL = BEGINNING COLUMN TO WRITE.
*                FWD = FIELD WIDTH.
*                CRC = CARRIAGE CONTROL.
*                      *LFD* IF LINE FEED AT THE END OF THE LINE
*                      *NLF* IF NO LINE FEED
*
*     EXIT       THE VALUE IS PRINTED TO THE REPORT FILE ACCORDING
*                TO THE SPECIFIED FORMAT.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM PVL        U;             # ADDRESS OF VALUE #
      ITEM DTY        I;             # DATA TYPE #
      ITEM BCL        I;             # BEGINNING COLUMN #
      ITEM FWD        I;             # FIELD WIDTH #
      ITEM CRC        I;             # CARRIAGE CONTROL #
 
#
****  PROC WRITEV - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC BZFILL;                 # BLANK/ZERO FILL ITEM #
        PROC RPLINE;                 # PRINT ONE REPORT LINE #
        FUNC XCDD C(10);             # BINARY TO DISPLAY DECIMAL #
        FUNC XCED C(10);             # BINARY TO DISPLAY *E* FORMAT #
        FUNC XCFD C(10);             # BINARY TO DISPLAY REAL #
        FUNC XCOD C(10);             # BINARY TO DISPLAY OCTAL #
        END
 
#
****  PROC WRITEV - XREF LIST END.
#
 
      DEF BLKC       #" "#;          # BLANK #
      DEF MAXF       #1.0E4#;        # MAXIMUM VALUE OF *F* FORMAT #
      DEF ZERC       #"0"#;          # CHARACTER 0 #
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
*CALL     COMABZF
 
#
*     LOCAL VARIABLES.
#
 
      ITEM N          I;             # TEMPORARY VARIABLE #
      ITEM NF         R;             # TEMPORARY VARIABLE #
      ITEM T1         I;             # TEMPORARY VARIABLE #
      ITEM T2         I;             # TEMPORARY VARIABLE #
 
      ARRAY P [0:0] P(1);            # TEMPORARY BUFFER #
        BEGIN  # ARRAY P #
        ITEM P$WD       C(00,00,10);  # 10 CHAR VALUE #
        ITEM P$WF       C(00,06,09);  # 9 LEAST SIGNIFICANT DIGITS #
        END  # ARRAY P #
 
      ARRAY TEM [0:0] P(1);          # DISPLAY CODE VALUE #
        BEGIN  # ARRAY TEM #
        ITEM T$WD       C(00,00,10);  # VALUE #
        ITEM T$W1       C(00,00,09);  # VALUE WITH NO POSTFIX #
        ITEM T$W2       C(00,54,01);  # *B* POSTFIX #
        END  # ARRAY TEM #
 
      BASED
      ARRAY VAL [0:0] P(1);          # VALUE  TO BE PRINTED #
        BEGIN  # ARRAY VAL #
        ITEM VAL$C      C(00,00,50);  # CHARACTER TYPE #
        ITEM VAL$N      I(00,00,60);  # INTEGER TYPE #
        ITEM VAL$F      R(00,00,60);  # REAL TYPE #
        END  # ARRAY VAL #
 
      SWITCH TYPE
             CHRS,                   # CHARACTER #
             FLPS,                   # FLOATING POINT #
             INTS,                   # INTEGER #
             OC1S,                   # OCTAL WITH *B* POSTFIX #
             OC2S,                   # OCTAL WITH NO POSTFIX #
             OC3S,                   # *B* POSTFIX, ZERO FILLED #
             OC4S,                   # OCTAL, ALLOWING FOR *UESC* #
             ;                       # END OF TYPE #
 
      LABEL  EXIT;                   # END CASE #
 
 
 
 
 
#
*     BEGIN WRITEV PROC.
#
 
      IF (P$L EQ NULL)               # NO REPORT FILE #
      THEN  # SUPPRESS REPORT FILE #
        BEGIN
        RETURN;
        END
 
      P<VAL>=LOC(PVL);
      GOTO TYPE[DTY];
 
CHRS:                                # CHARACTER #
      BZFILL(VAL,TYPFILL"BFILL",FWD);
      RPLINE(OFFA,C<0,FWD>VAL$C[0],BCL,FWD,CRC);
      RETURN;
 
FLPS:                                # FLOATING POINT #
      IF (VAL$F[0] GQ MAXF)          # PRINT IN *E* FORMAT #
      THEN
        BEGIN
        NF=VAL$F[0];
        T$WD[0]=XCED(NF);
        END
 
      ELSE                           # PRINT IN *F* FORMAT #
        BEGIN
        N=VAL$F[0]*1000.0 + 0.5;
        T$WD[0]=XCFD(N);
        END
 
      GOTO EXIT;
 
INTS:                                # INTEGER #
      T$WD[0]=XCDD(VAL$N[0]);
      GOTO EXIT;
 
OC1S:                                # OCTAL POSTFIXED WITH *B* #
      P$WD[0]=XCOD(VAL$N[0]);
      T$W1[0]=P$WF[0];
      T$W2[0]="B";
      GOTO EXIT;
 
OC2S:                                # OCTAL WITHOUT *B* POSTFIX #
      T$WD[0]=XCOD(VAL$N[0]);
      GOTO EXIT;
 
OC3S:                                # OCTAL NO POSTFIX, ZERO FILLED #
      T$WD[0]=XCOD(VAL$N[0]);
      SLOWFOR N=0 STEP 1 WHILE C<N,1>T$WD[0] EQ BLKC
      DO   #  CONVERT BLANK TO DISPLAY 0 #
        BEGIN
        C<N,1>T$WD[0]=ZERC;
        END
      GOTO EXIT;
 
OC4S:                                # OCTAL WITH *B*, SHIFTED *UESC* #
      T1 = P<DCHD>;
      T2 = P<DDSC>;
      P<DCHD> = LOC(DBUF);
      P<DDSC> = LOC(DDHD);
      P$WD[0]=XCOD(VAL$N[0]*2**DCHD$WD[DDSC$FW[UESC]]);
      P<DCHD> = T1;
      P<DDSC> = T2;
      T$W1[0]=P$WF[0];
      T$W2[0]="B";
 
EXIT:
      RPLINE(OFFA,C<10-FWD,FWD>T$WD[0],BCL,FWD,CRC);
      RETURN;
      END  # WRITEV #
 
      TERM
PROC WRTSUM((NIP));
# TITLE WRTSUM - WRITE SUMMARY FILE.  #
 
      BEGIN  # WRTSUM #
 
#
**    WRTSUM - WRITE SUMMARY FILE.
*
*     WRITE DATA BLOCK ELEMENTS TO SUMMARY FILE.
*
*     PROC WRTSUM((NIP))
*
*     ENTRY      TABLE *DCDT*.
*                NIP = NUMBER OF INTERVALS PER PAGE.
*
*     EXIT       THE AVERAGE AND STANDARD DEVIATION OF EACH
*                DATA BLOCK ELEMENT ARE WRITTEN TO THE SUMMARY
*                FILE.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM NIP        I;             # NUMBER OF INTERVALS PER PAGE #
 
#
****  PROC WRTSUM - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC WRITER;                 # WRITE EOR #
        PROC WRITEW;                 # *CIO* WRITEW #
        END
 
#
****  PROC WRTSUM - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL     COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM WA         I;             # ADDRESS OF DECODED BUFFER #
 
      BASED
      ARRAY SUM [0:0] P(1);;         # DUMMY BUFFER #
 
 
 
 
 
#
*     BEGIN WRTSUM PROC.
#
 
      P<DCDT>=LOC(DBUF[DCHL]);
      WA=1;
      SLOWFOR I=1 STEP 1 UNTIL NIP
      DO
        BEGIN
        P<SUM>=LOC(DCDT$WD[WA]);
        WRITEW(FETS,SUM,DCDL,0);     # WRITE AVERAGE #
        P<SUM>=LOC(DCDT$WD[DCDC*DCDL + WA]);
        WRITEW(FETS,SUM,DCDL,0);     # WRITE STANDARD DEVIATION #
        WRITER(FETS,1);              # WRITE EOR #
        WA=WA + DCDL;
        END
 
      RETURN;
      END  # WRTSUM #
 
      TERM
FUNC XCED((NUM)) C(10);
# TITLE XCED - CONVERT NUMBER TO THE DISPLAY *E* FORMAT.  #
 
      BEGIN  # XCED #
 
#
**    XCED - CONVERT NUMBER TO THE DISPLAY *E* FORMAT.
*
*     *XCED* CONVERTS A REAL NUMBER TO THE FORTRAN *E* FORMAT.
*     THE NUMBER HAS TO BE GREATER THAN 1.0E4 AND LESS THAN
*     (2**32 - 1).
*     THE RESULT IS A NORMALIZED NUMBER IN DISPLAY CODE.
*     THE FORMAT OF THE CONVERTED NUMBER IS :
*
*     BB.XXXXEYY
*
*     THE VALUE IS RIGHT-JUSTIFIED, BLANK FILLED.
*     IF THE EXPONENT *YY* IS ONLY ONE DIGIT LONG,
*     THE MANTISSA *XXXX* IS INCREASED TO FIVE DIGITS.
*
*     FUNC XCED((NUM)) C(10)
*
*     ENTRY     NUM = NUMBER TO BE CONVERTED.
*
*     EXIT      THE NUMBER IS NORMALIZED AND CONVERTED TO
*               DISPLAY CODE.
#
 
#
*     PARAMETER LIST.
#
 
      ITEM NUM        R;             # NUMBER TO BE CONVERTED #
 
#
****  FUNC XCED - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        FUNC XCDD C(10);             # BINARY TO DISPLAY DECIMAL #
        END
 
#
****  FUNC XCED - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # TURN OFF COMMON DECK LISTING #
 
*CALL      COMUCPD
 
#
*     LOCAL VARIABLES.
#
 
      ITEM EXP        I;             # EXPONENT #
      ITEM I          I;             # FOR LOOP CONTROL #
      ITEM J          I;             # FOR LOOP CONTROL #
      ITEM NUMF       R;             # TEMPORARY VARIABLE #
      ITEM NUMI       I;             # TEMPORARY VARIABLE #
      ITEM P          I;             # POSITION OF *E* #
      ITEM TEM1       C(10);         # TEMPORARY VARIABLE #
 
      ARRAY TEM [0:0] P(1);          # TEMPORARY STORAGE #
        BEGIN  # ARRAY TEM #
        ITEM T$WD       C(00,00,10);  # CONVERTED NUMBER #
        ITEM T$DP       C(00,12,01);  # DECIMAL POINT #
        END  # ARRAY TEM #
 
 
 
 
 
#
*     BEGIN XCED FUNC.
#
 
      NUMF=NUM;
      EXP=0;
 
#
*     NORMALIZE THE NUMBER.
#
 
      SLOWFOR I=1 WHILE (NUMF GQ 1.0)
      DO
        BEGIN
        NUMF=NUMF/10.0;
        EXP=EXP + 1;
        END
 
      T$WD[0]=XCDD(EXP);
      T$DP[0]=".";                   # DECIMAL POINT #
      P=8;                           # POSITION OF *E* #
      IF (EXP GQ 10)
      THEN
        BEGIN
        P=7;
        END
 
      NUMI=NUM;
      TEM1=XCDD(NUMI);
 
#
*     MOVE THE MOST SIGNIFICANT DIGITS TO *TEM*.
#
 
      SLOWFOR I=0 STEP 1 WHILE (C<I,1>TEM1 EQ " ")
      DO;                            # FIND THE FIRST DIGIT #
 
      FASTFOR J=3 STEP 1 UNTIL P-1
      DO
         BEGIN  # MOVE THE MOST SIGNIFICANT DIGITS #
         C<J,1>T$WD[0]=C<I,1>TEM1;
         I=I+1;
         END  # MOVE THE MOST SIGNIFICANT DIGITS #
 
      C<P,1>T$WD[0]="E";             # PLACE THE *E* CHARACTER #
      XCED=T$WD[0];
      RETURN;
      END  # XCED #
 
      TERM