*********************************************************************sdk ************************************************************************ * * Subroutine QSORTPF * * Function: * Sort pointers in pntarr on values in key (descending) * * Method: * Quicksort (H.A.R. Hoare, "Quicksort", Comp. J. 5(1):10-15 * (1962). * * Comment: * Code translated and adapted from Pascal version in * N. Wirth, Algorithms + Data Structures = Programs, * 1976 Prentice-Hall Inc, Englewood Cliffs, New Jersey. * * Arguments: * Np (i) number of elements to sort * Pntarr (i/o) 1 x np integer array of pointers * Key (i/o) sort key real array (1 x np) * Errcod (o) error code * errcod = 0 - no error * errcod = 1 - stack overflow * * History: * First attempts November 23 1991 S. Knight ************************************************************************ subroutine qsortpf ( np , pntarr , key , errcod ) implicit none * Arguments integer np integer pntarr( np ) real key( np ) integer errcod * Local variables integer i , j , l , r , s , x integer m parameter ( m = 12 ) integer stack( 2,m ) integer pntsav *----------------------------------------------------------------------- * Initialize error code errcod = 0 * Don't bother if nothing to sort if ( np .le. 1 ) return * Initialize stack s = 1 stack( 1,1 ) = 1 stack( 2,1 ) = np * Conditional loop 1 100 continue * Take top request from stack l = stack( 1,s ) r = stack( 2,s ) s = s - 1 * Conditional loop 2 200 continue * Split interval l-r until nothing left, chose middle of * interval as comparand i = l j = r x = ( i + j ) / 2 * Conditional loop 3 300 continue * Partition if ( key( pntarr(i) ) .gt. key( pntarr(x) ) ) then i = i + 1 goto 300 endif 310 if ( key( pntarr(x) ) .gt. key( pntarr(j) ) ) then j = j - 1 goto 310 endif * Swap and if necessary reset comparand pointer if ( i .le. j ) then pntsav = pntarr( i ) pntarr( i ) = pntarr( j ) pntarr( j ) = pntsav if ( x .eq. i ) then x = j else if ( x .eq. j ) then x = i endif i = i + 1 j = j - 1 endif * End of conditional loop 3 if ( i .le. j ) goto 300 * Set up requests: short interval now, long interval to stack if ( j - l .lt. r - i ) then if ( i .lt. r ) then * Stack request for sorting right partition s = s + 1 if ( s .gt. m ) goto 999 stack( 1,s ) = i stack( 2,s ) = r endif * and continue sorting left partition r = j else if ( l .lt. j ) then * Stack request for sorting left partition s = s + 1 if ( s .gt. m ) goto 999 stack( 1,s ) = l stack( 2,s ) = j endif * and continue sorting right partition l = i endif * End of conditional loop 2 if ( l .lt. r ) goto 200 * End of conditional loop 3 if ( s .gt. 0 ) goto 100 * All done return 999 errcod = 1 return end