FTN4
      PROGRAM QY19(5,90),92069-16060 REV.2001 791011    
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-18082
C     RELOC:     92069-16060
C 
C 
C************************************************************ 
C 
C 
C 
C 
C 
C ABSTRACT: 
C 
C   QY19 SORTS THE BLOCKS WHICH WERE WRITTEM TO THE DISC IN THE SEGMENT 
C   QY05, THEN REWRITES THE SELECT FILE ACCORDING TO THE SORTED ORDER.
C 
C   THE SORT IS DONE ON TWO LEVELS: MAJOR AND MINOR.  THE MODULE QSORT
C   IS RESPONSIBLE FOR THE MINOR SORT.  THEREFORE, SEE IT MORE MORE 
C   DESCRIPTION AT THE DETAIL LEVEL.
C 
C   MAJOR SORT: 
C 
C      THE MAJOR SORT, SORTS THREE BLOCKS FROM THE DISC IN MEMORY 
C      AT ONCE. 
C 
C 
C       TOPBLK                         CURBLK  ENDBLK 
C       --------------------------------------------- 
C      !      !      !       !        !       !      !
C DISC !      !      !       !        !       !      !
C      !      !      !       !        !       !      !
C       --------------------------------------------- 
C          !                              !       ! 
C           -------          -------------        ! 
C                 !          !       -------------- 
C                 !          !       !
C                 --------------------- 
C                 !      !      !      !
C    SORT BUFFER
C                 !      !      !      !
C                 --------------------- 
C                 LOWER    MID    UPPER 
C 
C 
C 
C      WHEN THE SELECTED THREE BLOCKS FROM THE DISC ARE SORTED THE
C      MIDDLE BLOCK FROM THE SORT BUFFER IS WRITTEN BACK TO ITS 
C      ORIGINAL SLOT AND THE NEXT BLOCK ON THE DISC IS SELECTED.
C 
C 
C       TOPBLK                         CURBLK  ENDBLK 
C       --------------------------------------------- 
C      !      !      !       !        !       !      !
C DISC !      !      !       !        !       !      !
C      !      !      !       !        !       !      !
C       --------------------------------------------- 
C          !                      !               ! 
C           -------          ------               ! 
C                 !          !       -------------- 
C                 !          !       !
C                 --------------------- 
C                 !      !      !      !
C    SORT BUFFER
C                 !      !      !      !
C                 --------------------- 
C                 LOWER    MID    UPPER 
C 
C 
C      WHEN ALL OF THE BLOCKS ON THE DISC HAVE BEEN SELECTED, THE 
C      TOPBLK AND THE ENDBLK IN THE SORT BUFFER ARE SORTED ACCORDING
C      TO ALL OF THE BLOCKS ON THE DISC.  (THIS IS BECAUSE ALL RECORDS
C      IN EACH BLOCK ON THE DISC HAVE HAD THEIR OPPORTUNITY TO MIGRATE
C      TO THE TOP BLOCK AND THE END BLOCK.
C 
C      THEREFORE, IT IS NO LONGER NECESSARY TO KEEP THEM IN THE SORT
C      PARTITION.  SO REMOVE THEM FROM CONSIDERATION - THAT IS TAKE 
C      THEM OUT OF THE SORT PARTITION.
C 
C 
C 
C 
C              TOPBLK          CURBLK  ENDBLK 
C       --------------------------------------------- 
C      !     !!      !       !        !       !!     !
C DISC !     !!      !       !        !       !!     !
C      !     !!      !       !        !       !!     !
C       --------------------------------------------- 
C                !               !        ! 
C                --          -----        ! 
C                 !          !       ------ 
C                 !          !       !
C                 --------------------- 
C                 !      !      !      !
C    SORT BUFFER
C                 !      !      !      !
C                 --------------------- 
C                 LOWER    MID    UPPER 
C 
C 
C      NOW SORT THE BUFFERS RECURSIVELY UNTIL THE SORT PARTITION
C      REDUCES TO 1 OR 2 BLOCKS. ( IT WILL REDUCE TO 1 BUFFER WHEN THE
C      TOTAL NUMBER OF BUFFERS IS ODD, 2 OTHERWISE.)
C 
C      WHEN THE PARTITION REDUCES ITSELF TO 1 BUFFER, SORT IT AND WRITE 
C      IT OUT.
C      WHEN THE PARTITION REDUCES TO 2, SORT THEM AND WRITE THEM OUT. 
C 
C      BE AWARE THAT THE TOTAL NUMBER OF BLOCKS MAY ONLY BE ONE OR TWO. 
C 
C      THE FOLLOWING CODE IS OPTIMIZED SO THAT DISC ACCESSES ARE
C      REDUCED AS MUCH AS POSSIBLE.  THE ABOVE DESCRIPTION IS NOT 
C      A FLOW CHART, BUT SIMPLY THE GENERAL ALGORITHM.
C 
C 
C 
C 
C 
C 
C      RRCNT   IS AN INTEGER VARIABLE,PASSED IN COMMON,WHICH CONTAINS 
C              THE RETRIEVED RECORD COUNT.
C 
C 
C 
      LOGICAL DDS 
      INTEGER UPPER 
      REAL RECORD 
      REAL BLOCKS 
      REAL CURBLK,TOPBLK,ENDBLK 
      INTEGER RECLF 
      INTEGER ISTAT(10) 
      INTEGER ID1(2),ID2(2) 
      INTEGER ERR2(8) 
      INTEGER ERR3(8) 
C 
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      INTEGER IFTRK,ISIZE,SECBLK,WRDBLK,RECBLK,LENGTH,KEY 
      INTEGER NTRAK,ILU 
      REAL BLKS 
C&&&&&&&&&&&& QS5COM &&&&&&&&&&&&&&&&& OCT 4 1978 &&&&&&&&& 
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),(D2,ID2) 
C 
C INTERNAL ERROR
      DATA ERR2/2H I,2HNT,2HER,2HNA,2HL ,2HER,2HRO,2HR /
C BREAK REQUESTED 
      DATA ERR3/2H B,2HRE,2HAK,2H R,2HEQ,2HUE,2HST,2HED/
C 
      DATA ID1/0,1/ 
      DATA ID2/0,2/ 
C 
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 WORK AREA
C 
      CALL INITX(IFTRK,ISIZE,SECBLK,ILU)
C 
C BLOCK = LOOP COUNTER
C N1    = THE NUMBER OF WORDS IN THE LAST BLOCK 
C IWRDS = THE NUMBER OF WORDS IN THE OTHER BLOCKS 
C TOPBLK = THE FIRST BLOCK IN THE PARTITION TO BE SORTED
C ENDBLK = THE LAST BLOCK IN THE PARTITION TO BE SORTED 
C 
C UPPER = THE LAST RECORD IN THE SORT BUFFER TO BE SORTED (FOR QSORT) 
C LOWER = THE FIRST RECORD IN THE SORT BUFFER TO BE SORTED(FOR QSORT) 
C 
C MID   = WORD OFFSET IN THE SORT BUFFER FOR THE MIDDLE BLOCK 
C IEND  = WORD OFFSET IN THE SORT BUFFER FOR THE LAST BLOCK 
C 
C 
C 
      BLOCKS = BLKS 
C 
C RECORDS LEFT = RRCNT - RRCNT / RECBLK * RECBLK
C 
      RB = DBLEI(RECBLK)
      IF(DCO(RB,RRCNT))10,20,20 
10    RECLF = ISNGL(DSB(RRCNT,(DMP(DDI(RRCNT,RB),RB)))) 
      IF(RECLF .EQ. 0) RECLF = RECBLK 
      GOTO 30 
C 
C THE # OF RECORDS IS LESS THAN OR EQUAL TO THE BLOCK SIZE
C 
20    CONTINUE
      RECLF = ISNGL(RRCNT)  
C 
C N1 = # OF WORDS IN THE LAST BLOCK 
C IWRDS = # OF WORDS IN THE REST OF THE BLOCKS
C 
30    CONTINUE
      N1 = RECLF * LENGTH / 2 
      IWRDS = LENGTH * RECBLK / 2 
C 
C READ FIRST BLOCK
C 
      TOPBLK = D1 
      UPPER = RECLF 
      CALL WORKX(1,IBUFF,IWRDS,TOPBLK)
      IF(DCO(BLOCKS,ID1)) 330,90,100
C 
C SORT FOR JUST 1 BLOCK 
C 
90    CONTINUE
      CALL QSORT(IBUFF,1,UPPER,KEY,LENGTH,LIST,ISTAT) 
      IWRDS = N1
      GOTO 210
C 
C PREPARE TO SORT ONLY TWO BLOCKS 
C 
C     MID POINTS TO THE MIDDLE BLOCK IN THE SORT BUFFER 
C     IEND POINTS TO THE LAST BLOCK IN THE SORT BUFFER
C 
C     UPPER POINTS TO THE LAST RECORD - WHEN THE NUMBER OF BLOCKS IS 2
C     ENDBLK POINTS TO THE LAST BLOCK  WHICH IS TO BE SORTED. 
C 
100   CONTINUE
      MID = 1 + IWRDS 
      IEND = MID + IWRDS
      UPPER = UPPER + RECBLK
      ENDBLK = BLOCKS 
      IF(DCO(BLOCKS,ID2)) 330,200,120 
C 
C SORT 3 BLOCKS OR MORE 
C 
C 
C 
C READ END BLOCK
C 
C     UPPER NOW POINTS TO THE LAST RECORD IN THE SORT BUFFER
C     CURBLK IS USED TO POINT TO THE BLOCK ON THE DISC WHICH IS CURRENTLY 
C              BEING USED AS THE MIDDLE BLOCK IN THE SORT BUFFER
C 
C 
120   CONTINUE
      UPPER = UPPER + RECBLK
      CALL WORKX(1,IBUFF(IEND),N1,ENDBLK) 
      CURBLK = DDE(ENDBLK)
C 
C READ IN NEXT TO LAST BLOCK AND PUT IT IN THE MIDDLE 
C 
150   CONTINUE
      CALL WORKX(1,IBUFF(MID),IWRDS,CURBLK) 
C 
C DO A QUICK SORT ON THE THREE BUFFERS
C 
      CALL QSORT(IBUFF,1,UPPER,KEY,LENGTH,LIST,ISTAT) 
C 
C IS BREAK REQUESTED
C 
      IF(IFBRK(IDUM) .NE. 0) GOTO 340 
C 
C HAS CURRENT BLOCK AND TOP BLOCK RUN INTO EACH OTHER 
C 
      IF(DCO(TOPBLK,DDE(CURBLK)))160,170,170
C 
C NO, WRITE OUT MIDDLE BLOCK
C 
160   CONTINUE
      CALL WORKX(2,IBUFF(MID),IWRDS,CURBLK) 
      CURBLK = DDE(CURBLK)
      GOTO 150
C 
C THE END BLOCKS ARE NOW ABSOLUTELY SORTED, SO WRITE THEM OUT 
C 
170   CONTINUE
      CALL WORKX(2,IBUFF,IWRDS,TOPBLK)
      CALL WORKX(2,IBUFF(IEND),N1,ENDBLK) 
C 
C SINCE THE TOP AND THE BOTTOM BLOCK IN THE SORT BUFFER HAVE
C BEEN SORTED AGAINEST EVERY BLOCK ON THE DISC, THEY ARE ABSOLUTELY 
C SORTED.  THEREFORE THEY NO LONGER NEED TO BE USED IN FUTURE PASSES. 
C 
C    DECREASE THE NUMBER OF BLOCKS BY TWO 
C 
      BLOCKS = DSB(BLOCKS,ID2)
C 
C THE CURBLK WAS LEFT POINTING TO THE BLOCK UNDER THE TOPBLK
C SINCE THE TOPBLK MUST BE MOVED DOWN ONE BLOCK SIMPLY SET IT 
C TO THE CURBLK.
C 
      TOPBLK = CURBLK 
C 
C MOVE THE END BLOCK UP ONE 
C 
      ENDBLK = DDE(ENDBLK)
C 
C SET THE SIZE OF THE LAST BLOCK IN THE SORT BUFFER TO THE
C SIZE OF THE REST OF THE BLOCKS, SINCE THE PARTIAL BLOCK HAS 
C ALREADY BEEN SORTED.
C 
      N1 = IWRDS
C 
C SET THE UPPER (WHICH REALLY POINTS TO THE LAST RECORD IN THE
C SORT BUFFER) TO THE LAST RECORD SINCE ALL THE BLOCKS WILL BE FULL 
C FROM NOW ON.
C 
      UPPER = 2 * RECBLK
C 
C MOVE THE MIDDLE BLOCK IN THE SORT BUFFER TO THE TOP BLOCK 
C SO TWO DISC ACCESSES MAY BE AVOIDED.
C 
      I = MID * 2 -1
      CALL SMOVE(IBUFF,I,I+(IWRDS*2)-1,IBUFF,1) 
C 
C SEE HOW MANY MORE BLOCKS TO SORT
C    IF THERE IS ONLY ONE - GO WRITE OUT THE BLOCK
C    IF THERE IS ONLY TWO - HANDLE THEM SPECIALLY 
C 
      IF(DCO(BLOCKS,ID2)) 210,200,120 
C 
C SORT THE LAST TWO BLOCKS
C 
200   CONTINUE
      CALL WORKX(1,IBUFF(MID),N1,ENDBLK)
      CALL QSORT(IBUFF,1,UPPER,KEY,LENGTH,LIST,ISTAT) 
C 
C WRITE OUT THE MIDDLE BLOCK
C 
      CALL WORKX(2,IBUFF(MID),N1,ENDBLK)
C 
C WRITE OUT THE TOP BLOCK 
C 
210   CONTINUE
      CALL WORKX(2,IBUFF,IWRDS,TOPBLK)
C 
C 
C WRITE RECORDS TO SELECT FILE
C 
C 
      RSEC = D1 
      CALL EREAD(JDCB,ISTAT,SELT,128,IL,RSEC) 
      IF(ISTAT .LT. 0) GOTO 280 
      IPTR = 9
C 
C 
C 
      RCOUNT = RRCNT
      IOFF = IWRDS+IWRDS
      CURBLK = D1 
C 
C 
C 
220   CONTINUE
      IF(IOFF .LT. IWRDS+IWRDS) GOTO 230
      CALL WORKX(1,IBUFF,IWRDS,CURBLK)
      CURBLK = DIN(CURBLK)
      IOFF = KEY + 1
C 
C 
C 
230   CONTINUE
      IF(IPTR .LT. 65) GOTO 250 
      CALL EWRIT(JDCB,ISTAT,SELT,128,RSEC)
      IF(ISTAT .LT. 0) GOTO 280 
      IPTR = 1
      RSEC = DIN(RSEC)
C 
C 
C 
250   CONTINUE
      CALL SMOVE(IBUFF,IOFF,IOFF+3,RECORD,1)
      IOFF = IOFF + LENGTH
      SELT(IPTR) = RECORD 
      IPTR = IPTR + 1 
C 
C 
C 
      IF (DDS(RCOUNT)) GOTO 260 
      GOTO 220
C 
C WRITE OUT THE LAST RECORD 
C 
260   CONTINUE
      IF(IPTR .EQ. 1) GOTO 270
      CALL EWRIT(JDCB,ISTAT,SELT,128,RSEC)
      IF(ISTAT .LT. 0) GOTO 280 
C 
C 
C 
C 
C 
C RELEASE TRACKS
C 
270   CONTINUE
      CALL EXEC(5,NTRAK,IFTRK,ILU)
      SNAM(2) = 2H06
      GOTO 320
C 
C 
C DBMS ERROR AND FMP ERROR
C 
C 
280   CONTINUE
      CALL EXEC(5,NTRAK,IFTRK,ILU)
      QSERR = ISTAT 
      SNAM(2) = 2H23
      GOTO 320
310   SNAM(2) = 2H
320   CALL LOAD(SNAM) 
C 
C INTERNAL ERROR
C 
330   CONTINUE
      CALL ERIO(2,ITTY,ERR2,7)
      GOTO 345
C 
C BREAK REQUESTED 
C 
340   CONTINUE
      CALL ERIO(2,ITTY,ERR3,8)
345   CALL EXEC(5,NTRAK,IFTRK,ILU)
      GOTO 310
      END 
$ 
                                                                                        