CTITLEFJSORT -- SORT DATA CARDS FOR A PROCESS 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR RALPH MCMILLAN 00020000 CA DESIGNER RALPH MCMILLAN 00030000 CA LANGUAGE VSFORTRAN 00040000 CA SYSTEM IBM AND CRAY 00050000 CA WRITTEN 06-27-86 00060000 C REVISED 06-27-86 REM - COPIED PART OF JGSORT FOR ACTUAL SORTING 00070000 C REVISED 08-12-86 REM - CHECK FOR PROCESS MODE TO DETERMINE 00080000 C ASCENDING/DESCENDING SORT 00090000 C REVISED 10-29-86 REM - CHECK NO SORT FLAG IN COLUMN 8. 00100000 C REVISED 05-04-87 REM - CHANGE COMMON TO SORTKY FOR NEW FORTRAN 00110000 C PTABMSTR. 00120000 C REVISED 05-15-87 DJP - INCREASED THE FIRST DIMENSION OF THE 00130000 C PROCLT ARRAY BY ONE. 00140000 C REVISED 08-17-87 REM - INCREASE DIMENSIONS OF PROCLC AND PROCLT. 00150000 C REVISED 09-01-87 REM. CHANGE VARIABLE NAMES:NPROCS TO MXPROC;. 00160000 C PROCLT TO PROCLI. 00170000 C REVISED 11-04-87 REM. INCREASE DIMENSION OF PROCLI AND INDEX 00180000 C ARRAYS USING VARIABLE NAMES. 00190000 C REVISED 11-17-87 REM. MODIFY SORTING LOOPS FOR EFFICIENCY AND 00200012 C MOVE SORT KEY TO CHAR*8 WORD BEFORE 00210012 C CONVERTING TO INTEGER. 00220012 CA 00230000 CA 00240000 CA CALL FJSORT (PROCLC, PROCLI, MXPROC, INDP, DCBD, MCIUSM, MCNUSM, 00250000 CA * DESCF) 00260000 CA 00270000 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00280000 CA 00290000 CA IN PROCLC CH4 PROCESSING LIST TABLE: CHARACTER VARIABLES00300000 CA IN PROCLI I4 PROCESSING LIST TABLE: INTEGER VARIABLES 00310000 CA IN MXPROC I4 MAXIMUM NUMBER OF PROCESSES ALLOWED 00320000 CA IN INDP I4 INDEX OF CURRENT PROCESS 00330000 CA IN DCBD I4 BDAM DCB ADDRESS FOR WORK FILE WITH CARDS 00340000 CA IN MCIUSM I4 INDEX FOR UNUSED BLANK COMMON 00350000 CA IN MCNUSM I4 NUMBER OF UNUSED WORDS IN BLANK COMMON 00360000 CA IN DESCF I4 DESCENDING ORDER FLAG. 0=NO. 1=YES. 00370000 CA 00380000 CA 00390000 CA FJSORT IS A SUBROUTINE CALLED BY CPPREP TO SORT THE DATA CARDS 00400000 CA FOR EACH PROCESS. 00410000 CA 00420000 CA SEE PROGRAM ISPARC FOR A FULL DESCRIPTION OF ARRAYS PROCLC AND 00430000 CA PROCLI. FJSETP CONTAINS THE DESCRIPTION OF PTABI AND PTABC. 00440000 CAEND 00450000 C 00460000 SUBROUTINE FJSORT (PROCLC, PROCLI, MXPROC, INDP, DCBD, MCIUSM, 00470000 * MCNUSM, DESCF) 00480000 C 00490000 IMPLICIT INTEGER(A-Z) 00500000 C 00510000 PARAMETER (NCOLS=15, NLINES=3, NKEYS=15) 00520000 PARAMETER (IXPTAB=4, IXNCDS=6, IXDA=7) 00530000 C 00540000 C COMMON AREA DECLARATIONS 00550000 C 00560000 COMMON /MPTABI/ NPTAB, PTABI(14, 250) 00570000 COMMON /MPTABC/ PTABC(5, 250) 00580000 CHARACTER*4 PTABC 00590000 INTEGER PTABI 00600000 C 00610000 COMMON /SORTKY/ SKEY, SKEYID 00620000 C 00630000 COMMON COM(1) 00640000 C 00650000 C INTEGER VARIABLES IN THE PARAMETER LIST 00660000 C 00670000 INTEGER PROCLI (15, MXPROC) 00680000 C 00690000 C CHARACTER VARIABLES IN THE PARAMETER LIST 00700000 C 00710000 CHARACTER*4 PROCLC (6, MXPROC) 00720000 C 00730000 C COMMON VARIABLES 00740000 C 00750000 INTEGER SKEY (NCOLS, NLINES, NKEYS) 00760000 INTEGER SKEYID (NKEYS) 00770000 C 00780000 C CHARACTER VARIABLES - LOCAL 00790000 C 00800000 CHARACTER*8 CSKEY 00810012 CHARACTER*1 PMODE 00820012 C 00830000 C READ DATA CARDS INTO MEMORY 00840000 C 00850000 INDX = MCIUSM 00860000 LINDX = INDX + MCNUSM - 1 00870000 PMODE = ' ' 00880000 DA = PROCLI(IXDA,INDP) 00890000 NOSORT= 0 00900000 C 00910000 DO 10 J = 1, PROCLI(IXNCDS,INDP) 00920000 CALL FORDSD (DCBD, DA, COM(INDX)) 00930000 C 00940000 C CHECK FOR NO SORT FLAG 00950000 C 00960000 IF (S1CPCH(COM(INDX+1),8,'^',1,1) .EQ. 0) THEN 00970000 CALL S1MVCH(' ',1,COM(INDX+1),8,1) 00980000 NOSORT = 1 00990000 END IF 01000000 C SAVE PROCESSING MODE 01010000 IF (S1CPCH(COM(INDX+1),8,' ',1,3) .EQ. 0) 01020000 * CALL S1MVCH(COM(INDX+1),7,PMODE,1,1) 01030000 DA = COM(INDX) 01040000 IF (DA .EQ. 0) GO TO 20 01050000 INDX = INDX + 21 01060000 IF (INDX .GT. LINDX) GO TO 500 01070000 C 01080000 10 CONTINUE 01090000 C 01100000 C DEFAULT PMODE TO S IF DESCENDING SORT FLAG IS ON 01110000 C 01120000 20 IF (PMODE .EQ. ' ' .AND. DESCF .EQ. 1) PMODE = 'S' 01130000 IF (NOSORT .NE. 0) GO TO 90 01140000 C 01150000 C FIND THE KEY INDEX 01160000 C 01170000 IPTAB = PROCLI(IXPTAB, INDP) 01180000 CSKEY = PTABC(2,IPTAB)(3:4) 01190012 KEYNO = S1CVBN (CSKEY, 1, 2) 01200012 C 01210000 DO 80 SNO = 1, NKEYS 01220000 IF (KEYNO .EQ. SKEYID(SNO)) GO TO 100 01230000 C 01240000 80 CONTINUE 01250000 C 01260000 C USE THE DEFAULT SORT KEY 01270000 C 01280000 90 SNO = 1 01290000 C 01300005 100 ENDLUP = PROCLI(IXNCDS,INDP) - 1 01310005 ENDLP2 = PROCLI(IXNCDS,INDP) / 2 01320002 C 01330000 DO 170 SNX = NCOLS, 1, -1 01340005 IF (SKEY(SNX, 1, SNO) .EQ. 0) GO TO 170 01350000 IF (SKEY(SNX, 1, SNO) .EQ. 99) GO TO 150 01360000 BGN = SKEY(SNX, 1, SNO) 01370000 NCHAR = SKEY(SNX, 2, SNO) 01380000 SWITCH = 1 01390002 K = PROCLI(IXNCDS,INDP) 01400002 C 01410000 DO 145 J = 1, ENDLUP 01420000 C 01430000 IF (SWITCH .EQ. 0) GO TO 170 01440002 K = K - 1 01450002 SWITCH = 0 01460002 C 01470002 DO 140 NCARD = 1, K 01480002 INDX = MCIUSM + (NCARD-1) * 21 01490000 IF (SKEY(SNX, 3, SNO) .EQ. 0) GO TO 110 01500000 IF (DESCF .EQ. 0 .OR. PMODE .NE. 'S') GO TO 110 01510000 C 01520000 C DESCENDING ORDER 01530000 C 01540000 IF (S1CPCH (COM(INDX+1), BGN, COM(INDX+22), BGN, NCHAR)) 01550000 * 120, 140, 140 01560000 C LT, EQ, GT 01570000 C 01580000 C ASCENDING ORDER 01590000 C 01600000 110 IF (S1CPCH (COM(INDX+1), BGN, COM(INDX+22), BGN, NCHAR)) 01610000 * 140, 140, 120 01620000 C 01630000 C SWITCH CARDS 01640000 C 01650000 120 DO 130 NCARDA = INDX+1, INDX+20 01660000 TEMP = COM(NCARDA) 01670000 COM(NCARDA) = COM(NCARDA+21) 01680000 COM(NCARDA+21) = TEMP 01690000 130 CONTINUE 01700000 C 01710000 SWITCH = 1 01720002 140 CONTINUE 01730000 C 01740000 145 CONTINUE 01750000 C 01760000 GO TO 170 01770002 C 01780000 C SINCE CARDS ARE CHAINED FROM LAST TO FIRST - REVERSE ALL CARDS 01790000 C 01800000 150 DO 160 NCARD=1, ENDLP2 01810002 INDX1 = MCIUSM + (NCARD-1) * 21 01820000 INDX2 = MCIUSM + (PROCLI(IXNCDS,INDP) - NCARD) * 21 01830000 C 01840000 DO 155 NCARDA = 1, 20 01850000 TEMP = COM(INDX1+NCARDA) 01860000 COM(INDX1+NCARDA) = COM(INDX2+NCARDA) 01870000 COM(INDX2+NCARDA) = TEMP 01880000 C 01890000 155 CONTINUE 01900000 C 01910000 160 CONTINUE 01920000 C 01930000 170 CONTINUE 01940000 C 01950000 C WRITE CARDS BACK TO WORK FILE 01960000 C 01970000 INDX = MCIUSM 01980000 DA = PROCLI(IXDA,INDP) 01990000 C 02000000 DO 180 J = 1, PROCLI(IXNCDS,INDP) 02010000 C 02020000 CALL FOWDSD (DCBD, DA, COM(INDX)) 02030000 DA = COM(INDX) 02040000 INDX = INDX + 21 02050000 C 02060000 180 CONTINUE 02070000 C 02080000 RETURN 02090000 C 02100000 500 WRITE (6, 9000) 02110000 CALL XDUMPX 02120000 C 02130000 9000 FORMAT ('-NOT ENOUGH BLANK COMMON. SEE PROGRAMMERS') 02140000 END 02150000