FTN4
      PROGRAM QY05(5,90),92069-16060 REV.1940 790523
C 
C 
C 
C*************************************************************
C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS    *
C RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C*************************************************************
C 
C 
C     SOURCE:    92069-18068
C     RELOC:     92069-16060
C 
C 
C************************************************************ 
C 
C 
C 
C THIS IS A MAIN PROGRAM MODULE THAT IS CALLED BY QS04 AND QS19 UPON THE
C RECOGNITION OF SORT STATEMENT(S) IN THE REPORT. QS05 WILL BUILD THE 
C WORK AREA WITH RECORD NUMBERS AND THEIR ASSOCIATED SORT KEYS IN 
C ACCORDANCE WITH THE REQUIREMENTS OF THE SORT SUBROUTINE.(IF THE WORK
C AREA IS NOT OF SUFFICIENT SIZE, QS05 WILL PRINT AN ERROR MESSAGE AND
C RETURN TO QS) 
C 
C IMPORTANT VARIABLES AND ARRAYS USED:
C 
C 
C      RRCNT   IS AN INTEGER VARIABLE,PASSED IN COMMON,WHICH CONTAINS 
C              THE RETRIEVED RECORD COUNT.
C 
C 
C 
      LOGICAL DDS 
      REAL RECORD 
      REAL CURBLK 
      INTEGER SECTRK,BLKTRK 
      INTEGER DZERO(2)
      INTEGER ISTAT(10) 
      INTEGER ISORT(42) 
      INTEGER ID1(2)
      INTEGER ERR1(16)
      INTEGER ERR2(9) 
      INTEGER ERR3(15)
C&&&&&&&&&&&& QS5COM &&&&&&&&&&&&&&&&& OCT 4 1978 &&&&&&&&& 
      INTEGER IFTRK,ISIZE,SECBLK,WRDBLK,RECBLK,LENGTH,KEY 
      INTEGER NTRAK,ILU 
      REAL BLKS 
C&&&&&&&&&&&& QS5COM &&&&&&&&&&&&&&&&& OCT 4 1978 &&&&&&&&& 
C 
C$$$$$$$$$$$$$$$$$$$ NOVEMBER 3,1978   $$$$$$$$$$$$$$$$$$$$$
      INTEGER INLU,ITTY,ILP,IDCB,JDCB,XEQ 
      INTEGER DBNAM,DBLEV,DSNAM,DINAM,SELECT,SNAM 
      INTEGER DSNUM,DINUM,PARM,LPARM,ECHO,QSERR 
      INTEGER IMA,IB,IBSZ,SECNO,IEND,ISCAN
      LOGICAL BREAK 
      INTEGER IPFLAG,IOFLAG,RMOTE 
      LOGICAL BATCH,XQBCH 
      INTEGER PAGCNT,LNCNT
      INTEGER PAGLEN,COLLIM 
      REAL    RRCNT 
      REAL    SELT,RSEC 
      INTEGER IPTR
      REAL    RCOUNT
      INTEGER S,R3,TRKNM,IDILU
      INTEGER R6
      REAL    ATOTAL
      INTEGER LIST,L,T,U
      INTEGER LEVSTR,LEVLEN 
      INTEGER IBUFF 
      INTEGER SS(7,100) 
C 
      COMMON INLU(145),ITTY(145),ILP(145),IDCB(145),JDCB(144),XEQ(145)
      COMMON DBNAM(10),DBLEV(3),DSNAM(3),DINAM(3),SELECT(6),SNAM(3) 
      COMMON DSNUM,DINUM,PARM(40),LPARM,ECHO,QSERR
      COMMON IMA(37),IB(896),IBSZ,SECNO,IEND,ISCAN
      COMMON BREAK
      COMMON IPFLAG,IOFLAG,RMOTE
      COMMON BATCH,XQBCH
      COMMON PAGCNT,LNCNT 
      COMMON PAGLEN,COLLIM
      COMMON RRCNT
      COMMON SELT(64),RSEC
      COMMON IPTR 
      COMMON RCOUNT 
      COMMON S(15,50),R3,TRKNM,IDILU
      COMMON R6 
      COMMON ATOTAL(6,5)
      COMMON LIST(101,6),L(7),T(5),U(7,5) 
      COMMON LEVSTR(66,5),LEVLEN(5) 
      COMMON IBUFF(2048)
C 
      EQUIVALENCE (S,SS)
C$$$$$$$$$$$$$$$$$$$ NOVEMBER 3,1978   $$$$$$$$$$$$$$$$$$$$$
C%%%%%%% QS5EQU %%%%%%%%%%%%%%%%%%%%%%%%%%%% OCT 5, 1978 %%%%%%%% 
      EQUIVALENCE(IB,IFTRK) 
      EQUIVALENCE(IB(2),ISIZE)
      EQUIVALENCE(IB(3),SECBLK) 
      EQUIVALENCE(IB(4),WRDBLK) 
      EQUIVALENCE(IB(5),RECBLK) 
      EQUIVALENCE(IB(6),LENGTH) 
      EQUIVALENCE(IB(7),KEY)
      EQUIVALENCE(IB(8),NTRAK)
      EQUIVALENCE(IB(9),ILU)
      EQUIVALENCE(IB(10),BLKS)
      EQUIVALENCE(IB(12),XXXXX) 
C%%%%%%% QS5EQU %%%%%%%%%%%%%%%%%%%%%%%%%%%% OCT 5, 1978 %%%%%%%% 
      EQUIVALENCE (D1,ID1)
C 
C INSUFFICIENT WORK AREA
      DATA ERR1/2H I,2HNS,2HUF,2HFI,                                    ERR1
     1 2HCI,2HEN,2HT ,2HWO,2HRK,2H A,                                   ERR1
     2 2HRE,2HA ,2HFO,2HR ,2HSO,2HRT/                                   ERR1
C SORT VALUE SIZES EXCEED LIMIT 
      DATA ERR3/2H S,2HOR,2HT ,2HVA,2HLU,2HE ,2HSI,2HZE,2HS ,2HEX,2HCE, ERR3
     12HED,2H L,2HIM,2HIT/
      DATA ID1/0,1/ 
      DATA DZERO/0,0/ 
C 
C     SECBLK - SECTORS PER BLOCK
C     WRDBLK  - WORDS PER BLOCK 
C     SECTRK  - SECTORS PER TRACK 
C     RECBLK  - RECORDS PER BLOCK 
C     BLKTRK  - BLOCKS PER TRACK
C     RECLF   - RECORDS LEFT IN LAST BLOCK
C     BLKS    - TOTAL NUMBER OF BLOCKS NEEDED 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C BEGIN 
C 
C INITIALIZE THE NUMBER OF 128 WORD SECTORS PER BLOCK 
C 
      SECBLK = 5
      WRDBLK = 5 * 128
C 
C INITIALIZE THE SIZE OF THE KEY FIELD AND THE SIZE OF THE SORT 
C RECORD
C 
C SIZE OF KEY = OFFSET OF LAST KEY + IT'S LENGTH * # ELELMENTS -1 
C LENGTH OF RECORD IS LENGTH OF KEY + SIZE OF D-INTEGER RECORD #
C 
      I = LIST(1,6) + 1 
      KEY = LIST(I,5) + LIST(I,3) * LIST(I,4) -1
      LENGTH = KEY + 4
C 
C VERIFY THAT THE SORT RECORDS DO NOT EXCEED THE BUFFERS IN QSORT 
C 
      IF(LENGTH .LE. 84) GOTO 20
      CALL ERIO(2,ITTY,ERR3,15) 
      GOTO 310
C 
C GET THE NUMBER OF 128 WORD SECTORS PER TRACK
C 
20    CONTINUE
      CALL EXEC(4,107777B,IFTRK,ILU,ISIZE)
      SECTRK = ISIZE/2
      RECBLK = WRDBLK/(LENGTH/2)
      IWRDS = RECBLK * LENGTH / 2 
C 
C GET THE NUMBER OF BLOCKS NEEDED TO HOLD ALL THE SORT DATA 
C 
      BLKS = DDI(RRCNT,DBLEI(RECBLK) )
      IF(DCO(BLKS,DZERO))25,25,24 
C 
C ALLOW FOR EXTRA 
C 
24    IF(DCO(DSB(RRCNT, DMP(BLKS,DBLEI(RECBLK))),DZERO)) 26,26,25 
25    BLKS = DIN(BLKS)
26    BLKTRK = SECTRK/SECBLK
      NTRAK = ISNGL(DDI(BLKS,DBLEI(BLKTRK))) + 1
      IF(NTRAK .LE. 0) NTRAK = 1
      CALL EXEC(4,NTRAK+100000B,IFTRK,ILU,ISIZE)
      ISIZE = BLKTRK * SECBLK * 2 
      IF(IFTRK .GE. 0) GOTO 30
C 
C NEED MORE SYSTEM TRACKS 
C 
      CALL ERIO(2,ITTY,ERR1,16) 
      GOTO 310
C 
C 
C READ THE SELECT FILE
C 
30    CONTINUE
      RSEC = D1 
      CALL EREAD(JDCB,ISTAT,SELT,128,IL,RSEC) 
      IF(ISTAT .LT. 0) GOTO 280 
      IPTR = 9
      RSEC = DIN(RSEC)
C 
C 
C READ ALL THE SORT RECORDS AND PUT THEM ON THE TRACKS
C 
C 
C INITIALIZE THE WORK AREA
C 
      CALL INITX(IFTRK,ISIZE,SECBLK,ILU)
C 
C GET SORT RECORDS ON DISC
C 
      RCOUNT = RRCNT
      IOFF = 1
      CURBLK = D1 
C 
C WRITE THE BLOCK WHEN IT IS FULL 
C 
40    CONTINUE
      IF(IOFF .LT. IWRDS+IWRDS) GOTO 45 
      CALL WORKX(2,IBUFF,IWRDS,CURBLK)
      IOFF = 1
      CURBLK = DIN(CURBLK)
C 
C GET THE SELECTED RECORD # FROM THE SELECT FILE
C 
45    CONTINUE
      IF(IPTR .LT. 65) GOTO 50
      CALL EREAD(JDCB,ISTAT,SELT,128,IL,RSEC) 
      IF(ISTAT .LT. 0) GOTO 280 
      IPTR = 1
      RSEC = DIN(RSEC)
C 
C GET RECORD # FROM SELECT FILE 
C 
50    CONTINUE
      RECORD = SELT(IPTR) 
      IPTR = IPTR + 1 
C 
C READ RECORD FROM DATA SET 
C 
      CALL DBGET(DBNAM,DSNUM,4,ISTAT,LIST(1,6), 
     &                             IBUFF((IOFF+1)/2),RECORD)
      IF(ISTAT .NE. 0) GOTO 280 
C 
C PUT RECORD IN SORT TRACKS 
C 
      IOFF = IOFF + KEY 
      CALL SMOVE(RECORD,1,4,IBUFF,IOFF) 
      IOFF = IOFF+4 
      IF(DDS(RCOUNT)) GOTO 80 
      GOTO 40 
C 
C 
C 
C 
C 
C 
80    CONTINUE
      CALL WORKX(2,IBUFF,IWRDS,CURBLK)
      SNAM(2) = 2H19
      GOTO 320
C 
C DBMS ERROR AND FMP ERROR
C 
280   CONTINUE
      CALL EXEC(5,NTRAK,IFTRK,ILU)
      QSERR = ISTAT 
      SNAM(2) = 2H23
      GOTO 320
C 
C 
C 
300   CALL EXEC(5,NTRAK,IFTRK,ILU)
310   SNAM(2) = 2H
C 
C 
C EXIT
C 
C 
320   CONTINUE
      CALL LOAD(SNAM) 
      END 
$ 
                                                                                                                                                                                                      