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 $