*DECK,HPA2
      OVCAP.
      SUBROUTINE HPA2 
* 
**           DESCRIPTION
*            ------------ 
*            HPA2 - CONTROL PROGRAM FOR SORT ROUTINES 
*            IN OVERLAY  ( 2,0 )
* 
*          CALLED BY
*          -----------
*           OVERLAY HPA2 IS CALLED BY HPA MAIN CONTROL
*          TO PERFORM INITIAL SORT OF SEF , 
*           TO PERFORM SORT FOR HISTORY UPDATE, 
*           AND SORT FOR MEDIA REPORTS. 
* 
* 
*CALL,HPACOM1 
* 
      EXTERNAL RMDXIT 
* 
*     TIME PRINT OUT CONTROLLED BY ( X=T) PARAMETER                     000700
      IF (FROG(6) .NE. L"T") GO TO 10 
      CALL SECOND (CP)
      PRINT 9,CP                                                        000730
    9 FORMAT ( ' ENTER HPA2 , SECOND = ',F10.3) 
   10 CONTINUE                                                          000750
* 
*         TEST THE SORTKEY
      IF (FLAGS(9) .EQ. 2) GO TO 50 
      IF (FLAGS(9) .EQ. 3) GO TO 100
* 
*         BUILD HARDWARE CONFIGURATION TABLE IF MMF PARAMETER SET 
      IF (FLAGS(25) .NE. 0) THEN
      CALL XOVCAP ('HPA23',0,0) 
         CALL UOVCAP ('HPA23')
         ENDIF
* 
*         LOAD OVERLAY 2,2 AND PERFORM DSA AND ANY REQUESTED BYPASS 
*         PARAMETERS, MOVING DATA FROM *RSEF* TO *SCR1* IN THE
*         PROCESS.  THEN LOAD OVERLAY 2,1 TO DO THE SORT, USING *SCR1*
*         AS SORT INPUT.  OUTPUT FROM SORT WILL BE *SEF*. 
* 
      CALL RMREWND (RSEF) 
      CALL RMREWND (SCR1) 
  
      CALL XOVCAP ('HPA22',0,0) 
      CALL UOVCAP ('HPA22') 
      CALL RMREWND (RSEF) 
      CALL RMREWND (SCR1) 
* 
*         SAVE CONTENT OF RSEF, THEN SET *RSEF* EQUAL TO *SCR1* FOR 
*         THIS SORT.
* 
      SAVESEF=RSEF
      RSEF=SCR1 
      CALL RMREWND (SEF)
      CALL STFACE2 (RSEF,SEF) 
*         RESET THE DX FIT FIELDS AFTER SORT 1. 
      CALL STOREF(FITTBL(1,RSEF),L"DX",RMDXIT)
      CALL STOREF(FITTBL(1,SEF),L"DX",RMDXIT) 
      CALL RMREWND(SCR1)
      CALL RMFILEM(SCR1)
      CALL RMREWND(SCR1)
      CALL RMREWND(SEF) 
* 
*         RESET *RSEF* TO NOMINAL VALUE 
* 
      RSEF = SAVESEF
      GO TO 900 
  
*        CALL SORT FOR HISTORY (FLAGS(9) = 2)                            HPA402R
                                                                        000190
   50 CALL RMREWND (SEF)
      CALL RMREWND (SCR3) 
      CALL RMFILEM (SCR3) 
      CALL RMREWND (SCR3) 
      CALL STFACE2 (SEF,SCR3) 
*         RESET THE DX FIT FIELDS AFTER SORT 2. 
      CALL STOREF (FITTBL(1,SEF),L"DX",RMDXIT)
      CALL STOREF (FITTBL(1,SCR3),L"DX",RMDXIT) 
      GO TO 900                                                         000700
*                                                                        HPA402R
*        (FLAGS(9) = 3)                                                  HPA402R
  100 CALL RMREWND (SCR1) 
      CALL RMREWND (SCR3) 
      CALL RMFILEM (SCR3) 
      CALL RMREWND (SCR3) 
      CALL STFACE2 (SCR1,SCR3)
*         RESET THE DX FIT FIELDS AFTER SORT 3. 
      CALL STOREF (FITTBL(1,SCR1),L"DX",RMDXIT) 
      CALL STOREF (FITTBL(1,SCR3),L"DX",RMDXIT) 
  
  900 CONTINUE
       END
*IF -DEF,HPSORT,1 
      SUBROUTINE ISUM2(RETCODE,IN,RL) 
*IF DEF,HPSORT,1
      SUBROUTINE ISUM2 (IN, I80)
* 
**
*         *ISUM2* GENERATES "THE SUM OF SQUARES" FOR USE IN THE 
*         STANDARD DEVIATION DETERMINATION ROUTINE. 
* 
*         ************************ WARNING ************************ 
*         THIS SUBROUTINE CONTAINS UPDATE DEFINE DIRECTIVES,
*         MAKING IT ACCESSIBLE TO BOTH SORT/MERGE AND HPSORT USERS. 
*         CONSULT A SOURCE LISTING WHEN MODIFYING.
* 
*         ENTRIES - CALLED FROM SORT/MERGE EXIT 3 AND HPSORT *PROUT2* 
* 
*         EXITS -  SORT/MERGE SMRTN(0) AND HPSORT RETURN
* 
*      ALTERS  AENTRYS = NUMBER OF VSNS PROCESSED 
*              AERRSUM = SUMMATION OF SQUARE OF ERRORS FOR LATER USE
*              ASUMM   = INTERNAL SUMMATION USAGE 
*              NEST    = INTERNAL COUNT OF ESTS VSN USED ON 
*              IEST    = EST HOLDING CELL 
* 
*CALL HPACOM1 
*CALL COMHPASPE 
  
      DIMENSION IN(8) 
  
      UNRCV = SHIFT(IN(2),-11) .AND. O"1" 
      WRITE = IN(5) .AND. O"1"
      IERRCOD = IN(1) .AND. O"7777" 
  
*     EXCLUDE CORRECTED READ/WRITE AND LATE DATA MSGS FROM CALCULATION
      IF ((IERRCOD .GE. O"2450") .AND. (IERRCOD .LE. O"2452")) GO TO 100
  
      IF ((IN(5) .AND. O"77777777777700000000") .EQ. INVSN) GO TO 40
      AERRSUM = AERRSUM + (ASUMM * NEST) ** 2 
      INVSN = IN(5) .AND. O"77777777777700000000" 
      ASUMM = IEST = NEST = 0 
      AENTRYS = AENTRYS + 1 
   40 IF ((IERRCOD .EQ. O"60")) GO TO 50
      ASUMM = ASUMM + (1 - UNRCV) + 3 * (UNRCV * (1 - WRITE)) 
   50 INEST = SHIFT(IN(2),-12) .AND. O"7777"
      IF (IEST .EQ. INEST) GO TO 100
      IEST = INEST
      NEST = NEST + 1 
  
*       PASS ON THIS RECORD 
  100 CONTINUE
*IF,-DEF,HPSORT,1 
      RETCODE = 0 
      RETURN
      END 
*IF,-DEF,HPSORT,1 
      SUBROUTINE POST2(RETCODE,IN,RL) 
*IF,DEF,HPSORT,1
      SUBROUTINE POST2 (IN, PFLAG, IOUT2) 
* 
**
*         *POST2* COMPRESSES SIMILAR ERRORS ON THE SEF FILE, AFTER
*         THE RECORDS HAVE BEEN SORTED. 
* 
*         ************************ WARNING ************************ 
*         THIS SUBROUTINE CONTAINS UPDATE DEFINE DIRECTIVES,
*         MAKING IT ACCESSIBLE TO BOTH SORT/MERGE AND HPSORT USERS. 
*         CONSULT A SOURCE LISTING WHEN MODIFYING.
* 
*         ENTRIES - CALLED FROM SORT/MERGE EXIT 3 AND HPSORT *PROUT2* 
* 
*         EXITS   - SORT/MERGE RETCODE(0) TO RETAIN RECORD
*                                     (1) TO DELETE RECORD
*                  HPSORT PFLAG = 0 TO RETAIN  RECORD 
*                                 1 TO DISCARD RECORD 
* 
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
      IMPLICIT INTEGER(F-Z) 
*CALL COMHPASPE 
  
      DIMENSION IN(8), IOUT2(8) 
      DIMENSION LCN(21) 
      DATA MLTFSZ /21/
  
      RTY = SHIFT(IN(1),-42) .AND. O"777" 
      MTY = IN(1) .AND. O"7777" 
      IEST = SHIFT(IN(2),-12) .AND. O"7777" 
      IBLOCK = IN(4) .AND. O"7777 7777" 
  
      DO 40 I = 1, 8
      IOUT2(I) = IOUT1(I) 
   40 IOUT1(I) = IN(I)
      PASS = PASS + 1 
  
*     ELIMINATE LCN REDUNDANCY
      IF (RTY .NE. O"75") GO TO 41
      TIME = SHIFT(IN(2),18) .AND. O"77 7777" 
      SEQ = SHIFT(IN(6),16) .AND. O"377"
      IF (SEQ .EQ. 0) SEQ = Z"FFF"
      IF ((IEST .EQ. OLDEST) .AND. (MTY .EQ. OLDERR)) GO TO 304 
*     CLEAR ARRAY FOR NEW HUI AND/OR MESSAGE TYPE 
      DO 302 I = 1,MLTFSZ 
  302 LCN(I) = 0
      LCNTIME = OLDTIME = TIME
      OLDEST = IEST 
      OLDERR = MTY
      SEQCNT = 0
*     CHECK FOR ARRAY INITIALIZATION
  304 IF (LCNTIME .NE. TIME) GO TO 310
*     STORE SEQ # FOR INITIALIZATION OF NEW HUI/MTY AND OUTPUT RECORD 
      DO 306 I = 1,MLTFSZ 
      IF (LCN(I) .EQ. 0) GO TO 308
  306 CONTINUE
      GO TO 700 
  308 LCN(I) = SEQ
      GO TO 700 
*     CHECK FOR NEW SAMPLE TIME 
  310 IF (OLDTIME .NE. TIME) GO TO 314
*     COMPARE SEQ #S OF SAME SAMPLE TIME
  312 SEQCNT = SEQCNT + 1 
      IF (SEQCNT .GT. MLTFSZ) GO TO 320 
      IF (LCN(SEQCNT) .EQ. SEQ) GO TO 320 
*     STORE NEW SEQ # FROM SAMPLE TIME AND OUTPUT RECORD
      LCN(SEQCNT) = SEQ 
      GO TO 700 
*     PROCESS NEW MLTF SAMPLE TIME
  314 SEQCNT = 0
      LCNTIME = OLDTIME 
      OLDTIME = TIME
      GO TO 312 
*     DELETE ENTRY FROM SAMPLE TIME WHICH CONTAINS SAVE SEQ # 
  320 DO 322 I = 1,8
  322 IOUT1(I) = IOUT2(I) 
      GO TO 800 
   41 CONTINUE
  
*         COMPRESS THE RETRYS OF AN OLD DP OR OLD DE MESSAGE (NOS)
*         (THOSE THAT DO NOT HAVE ONE WORD READS) 
      IF (MTY .EQ. O"355") GO TO 42 
  
*         COMPRESS THE RETRYS OF TAPE ERROR RECORDS (NON-FSC) 
      IF (((RTY .LT. O"30") .OR. (RTY .GT. O"37")) .AND.
     .     (RTY .NE. O"47") .AND. (RTY .NE. O"55")) GO TO 200 
      IF ((MTY .EQ. O"60") .OR. (MTY .EQ. O"61")) GO TO 100 
      IF ((MTY .GE. O"2450") .AND. (MTY .LE. O"2452")) GO TO 100
      IF (RTY .EQ. O"33") GO TO 100 
      IF (RTY.EQ.O"30") GO TO 100 
      IF (RTY .EQ. O"55") GO TO 100 
      IF (RTY .EQ. O"47") GO TO 100 
  
      IF (IBLOCK .NE. 0) GO TO 42 
      IF (RTY .LT. O"33") GO TO 100 
  
*     CHECK IF ALERT BIT SET IN GENERAL STATUS W. 1 OR UNRECOVERED ERROR
   42 IF (((SHIFT(IOUT2(4),13) .AND. 1) .NE. 0) .OR.
     .    ((IOUT2(2) .AND. O"4000") .NE. 0)) GO TO 100
      IF ((RTY.NE.OLDTYP) .OR. (MTY.NE.OLDERR) .OR. (IBLOCK.NE.OLDBLK)
     . .OR. (IEST.NE.OLDEST) .OR. (IN(3).NE.OLDJOB) .OR.
     .((IN(5).AND.O"77777777777700000000").NE.OLDVSN)) GO TO 100
  
*         RECORD CAN BE COMPRESSED
      DO 45 I = 1,8 
   45 IOUT1(I) = IOUT2(I) 
      IOUT1(2) = IN(2)
      IOUT1(4) = IOUT1(4) .AND. O"7777 7777 7777 7777"
      RETRY = IN(4) .AND. MASK(12)
      IOUT1(4) = IOUT1(4) .OR. RETRY
      GO TO 800 
  
*       RECORD CANNOT BE COMPRESSED 
  100 OLDTYP = RTY
      OLDERR = MTY
      OLDEST = IEST 
      OLDJOB = IN(3)
      OLDVSN = IN(5).AND.O"77777777777700000000"
      OLDBLK = IBLOCK 
  
  200 IF (PASS .EQ. 1) GO TO 800
  
*     CHECK FOR AN ECS/ESM/STORNET ERROR MESSAGE FROM NOS 
      IF ((MTY .NE. O"356") .AND. ((IN(2) .AND. O"377") .NE. R"SN"))
     .    GO TO 700 
      IF ((MTY .NE. O"40") .AND. (MTY .NE. O"41") .AND. (MTY .NE. O"50")
     .   .AND.(MTY .NE. O"100") .AND. (MTY .NE. O"363")) GO TO 700
      MSG = SHIFT(IN(6),-12).AND.O"3777 7777" 
      IF (MSG.EQ.R"1ST") IOUT1(6) = AND(IOUT1(6),O"77777777400000007777"
     +) 
      IF((MSG.EQ.R"GOOD").OR.(MSG.EQ.R"BAD").OR.(MSG.EQ.R"UGLY")) GO TO 
     +400 
      GO TO 700 
  
*          COMBINE UP TO 3 SEF ECS MESSAGES WITH GOOD AND BAD DATA
  400 DO 410 I = 1,8
  410 IOUT1(I) = IOUT2(I) 
  
*         STORE A FLAG THAT TELLS IF THERE WAS GOOD, BAD, OR UGLY DATA. 
*         (UGLY = CAN'T DETERMINE GOOD OR BAD DATA) 
      MSGFL = 0 
      IF (MSG .EQ. R"GOOD") MSGFL = 1 
      IF (MSG .EQ. R"BAD") MSGFL = 2
      IF (MSG .EQ. R"UGLY") MSGFL = 4 
      SVFOUR = SHIFT(IOUT1(4),57) 
      IOUT1(4) = SHIFT(OR(SVFOUR,MSGFL),3)
      J = 7 
      IF (MSG.EQ.R"BAD") J = 8
      IOUT1(J) = IN(J)
      GO TO 800 
  
*          PASS ON THE OUTPUT RECORD
  700 CONTINUE
*IF -DEF,HPSORT,3 
      DO 705 I=1,8
  705 IN(I) = IOUT2(I)
      RETCODE = 0 
*IF DEF,HPSORT,1
      PFLAG = 0 
      RETURN
  
*           DELETE THE OUTPUT RECORD
  800 CONTINUE
*IF,-DEF,HPSORT,1 
      RETCODE = 1 
*IF DEF,HPSORT,1
      PFLAG = 1 
      RETURN
      END 
