| 1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495 |
- *DECK MC20AD
- SUBROUTINE MC20AD (NC, MAXA, A, INUM, JPTR, JNUM, JDISP)
- C***BEGIN PROLOGUE MC20AD
- C***SUBSIDIARY
- C***PURPOSE Subsidiary to DSPLP
- C***LIBRARY SLATEC
- C***TYPE DOUBLE PRECISION (MC20AS-S, MC20AD-D)
- C***AUTHOR (UNKNOWN)
- C***DESCRIPTION
- C
- C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
- C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE
- C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
- C THE FINAL LETTER =D= IN THE NAMES USED HERE.
- C REVISED SEP. 13, 1979.
- C
- C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
- C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL
- C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
- C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES
- C DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
- C
- C***SEE ALSO DSPLP
- C***ROUTINES CALLED (NONE)
- C***REVISION HISTORY (YYMMDD)
- C 811215 DATE WRITTEN
- C 890831 Modified array declarations. (WRB)
- C 891214 Prologue converted to Version 4.0 format. (BAB)
- C 900402 Added TYPE section. (WRB)
- C***END PROLOGUE MC20AD
- INTEGER INUM(*), JNUM(*)
- DOUBLE PRECISION A(*),ACE,ACEP
- DIMENSION JPTR(NC)
- C***FIRST EXECUTABLE STATEMENT MC20AD
- NULL = -JDISP
- C** CLEAR JPTR
- DO 10 J=1,NC
- JPTR(J) = 0
- 10 CONTINUE
- C** COUNT THE NUMBER OF ELEMENTS IN EACH COLUMN.
- DO 20 K=1,MAXA
- J = JNUM(K) + JDISP
- JPTR(J) = JPTR(J) + 1
- 20 CONTINUE
- C** SET THE JPTR ARRAY
- K = 1
- DO 30 J=1,NC
- KR = K + JPTR(J)
- JPTR(J) = K
- K = KR
- 30 CONTINUE
- C
- C** REORDER THE ELEMENTS INTO COLUMN ORDER. THE ALGORITHM IS AN
- C IN-PLACE SORT AND IS OF ORDER MAXA.
- DO 50 I=1,MAXA
- C ESTABLISH THE CURRENT ENTRY.
- JCE = JNUM(I) + JDISP
- IF (JCE.EQ.0) GO TO 50
- ACE = A(I)
- ICE = INUM(I)
- C CLEAR THE LOCATION VACATED.
- JNUM(I) = NULL
- C CHAIN FROM CURRENT ENTRY TO STORE ITEMS.
- DO 40 J=1,MAXA
- C CURRENT ENTRY NOT IN CORRECT POSITION. DETERMINE CORRECT
- C POSITION TO STORE ENTRY.
- LOC = JPTR(JCE)
- JPTR(JCE) = JPTR(JCE) + 1
- C SAVE CONTENTS OF THAT LOCATION.
- ACEP = A(LOC)
- ICEP = INUM(LOC)
- JCEP = JNUM(LOC)
- C STORE CURRENT ENTRY.
- A(LOC) = ACE
- INUM(LOC) = ICE
- JNUM(LOC) = NULL
- C CHECK IF NEXT CURRENT ENTRY NEEDS TO BE PROCESSED.
- IF (JCEP.EQ.NULL) GO TO 50
- C IT DOES. COPY INTO CURRENT ENTRY.
- ACE = ACEP
- ICE = ICEP
- JCE = JCEP + JDISP
- 40 CONTINUE
- C
- 50 CONTINUE
- C
- C** RESET JPTR VECTOR.
- JA = 1
- DO 60 J=1,NC
- JB = JPTR(J)
- JPTR(J) = JA
- JA = JB
- 60 CONTINUE
- RETURN
- END
|
