1 SUBROUTINE MC20AS(NC, MAXA, A, INUM, JPTR, JNUM, JDISP) 2C***BEGIN PROLOGUE MC20AS 3C***REFER TO SPLP 4C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM 5C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE 6C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING 7C THE FINAL LETTER =S= IN THE NAMES USED HERE. 8C REVISED SEP. 13, 1979. 9C 10C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES 11C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL 12C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN 13C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES 14C SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. 15C***ROUTINES CALLED (NONE) 16C***END PROLOGUE MC20AS 17 INTEGER INUM(MAXA), JNUM(MAXA) 18 REAL A(MAXA) 19 DIMENSION JPTR(NC) 20C***FIRST EXECUTABLE STATEMENT MC20AS 21 NULL = -JDISP 22C** CLEAR JPTR 23 DO 10 J=1,NC 24 JPTR(J) = 0 25 10 CONTINUE 26C** COUNT THE NUMBER OF ELEMENTS IN EACH COLUMN. 27 DO 20 K=1,MAXA 28 J = JNUM(K) + JDISP 29 JPTR(J) = JPTR(J) + 1 30 20 CONTINUE 31C** SET THE JPTR ARRAY 32 K = 1 33 DO 30 J=1,NC 34 KR = K + JPTR(J) 35 JPTR(J) = K 36 K = KR 37 30 CONTINUE 38C 39C** REORDER THE ELEMENTS INTO COLUMN ORDER. THE ALGORITHM IS AN 40C IN-PLACE SORT AND IS OF ORDER MAXA. 41 DO 50 I=1,MAXA 42C ESTABLISH THE CURRENT ENTRY. 43 JCE = JNUM(I) + JDISP 44 IF (JCE.EQ.0) GO TO 50 45 ACE = A(I) 46 ICE = INUM(I) 47C CLEAR THE LOCATION VACATED. 48 JNUM(I) = NULL 49C CHAIN FROM CURRENT ENTRY TO STORE ITEMS. 50 DO 40 J=1,MAXA 51C CURRENT ENTRY NOT IN CORRECT POSITION. DETERMINE CORRECT 52C POSITION TO STORE ENTRY. 53 LOC = JPTR(JCE) 54 JPTR(JCE) = JPTR(JCE) + 1 55C SAVE CONTENTS OF THAT LOCATION. 56 ACEP = A(LOC) 57 ICEP = INUM(LOC) 58 JCEP = JNUM(LOC) 59C STORE CURRENT ENTRY. 60 A(LOC) = ACE 61 INUM(LOC) = ICE 62 JNUM(LOC) = NULL 63C CHECK IF NEXT CURRENT ENTRY NEEDS TO BE PROCESSED. 64 IF (JCEP.EQ.NULL) GO TO 50 65C IT DOES. COPY INTO CURRENT ENTRY. 66 ACE = ACEP 67 ICE = ICEP 68 JCE = JCEP + JDISP 69 40 CONTINUE 70C 71 50 CONTINUE 72C 73C** RESET JPTR VECTOR. 74 JA = 1 75 DO 60 J=1,NC 76 JB = JPTR(J) 77 JPTR(J) = JA 78 JA = JB 79 60 CONTINUE 80 RETURN 81 END 82