Télécharger dlasrt.eso

Retour à la liste

Numérotation des lignes :

  1. C DLASRT SOURCE BP208322 15/10/13 21:15:40 8670
  2. *> \brief \b DLASRT sorts numbers in increasing or decreasing order.
  3. *
  4. * =========== DOCUMENTATION ===========
  5. *
  6. * Online html documentation available at
  7. * http://www.netlib.org/lapack/explore-html/
  8. *
  9. *> \htmlonly
  10. *> Download DLASRT + dependencies
  11. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasrt.f">
  12. *> [TGZ]</a>
  13. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasrt.f">
  14. *> [ZIP]</a>
  15. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasrt.f">
  16. *> [TXT]</a>
  17. *> \endhtmlonly
  18. *
  19. * Definition:
  20. * ===========
  21. *
  22. * SUBROUTINE DLASRT( ID, N, D, INFO )
  23. *
  24. * .. Scalar Arguments ..
  25. * CHARACTER ID
  26. * INTEGER INFO, N
  27. * ..
  28. * .. Array Arguments ..
  29. * REAL*8 D( * )
  30. * ..
  31. *
  32. *
  33. *> \par Purpose:
  34. * =============
  35. *>
  36. *> \verbatim
  37. *>
  38. *> Sort the numbers in D in increasing order (if ID = 'I') or
  39. *> in decreasing order (if ID = 'D' ).
  40. *>
  41. *> Use Quick Sort, reverting to Insertion sort on arrays of
  42. *> size <= 20. Dimension of STACK limits N to about 2**32.
  43. *> \endverbatim
  44. *
  45. * Arguments:
  46. * ==========
  47. *
  48. *> \param[in] ID
  49. *> \verbatim
  50. *> ID is CHARACTER*1
  51. *> = 'I': sort D in increasing order;
  52. *> = 'D': sort D in decreasing order.
  53. *> \endverbatim
  54. *>
  55. *> \param[in] N
  56. *> \verbatim
  57. *> N is INTEGER
  58. *> The length of the array D.
  59. *> \endverbatim
  60. *>
  61. *> \param[in,out] D
  62. *> \verbatim
  63. *> D is DOUBLE PRECISION array, dimension (N)
  64. *> On entry, the array to be sorted.
  65. *> On exit, D has been sorted into increasing order
  66. *> (D(1) <= ... <= D(N) ) or into decreasing order
  67. *> (D(1) >= ... >= D(N) ), depending on ID.
  68. *> \endverbatim
  69. *>
  70. *> \param[out] INFO
  71. *> \verbatim
  72. *> INFO is INTEGER
  73. *> = 0: successful exit
  74. *> < 0: if INFO = -i, the i-th argument had an illegal value
  75. *> \endverbatim
  76. *
  77. * Authors:
  78. * ========
  79. *
  80. *> \author Univ. of Tennessee
  81. *> \author Univ. of California Berkeley
  82. *> \author Univ. of Colorado Denver
  83. *> \author NAG Ltd.
  84. *
  85. *> \date September 2012
  86. *
  87. *> \ingroup auxOTHERcomputational
  88. *
  89. * =====================================================================
  90. SUBROUTINE DLASRT( ID, N, D, INFO )
  91. *
  92. * -- LAPACK computational routine (version 3.4.2) --
  93. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  94. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  95. * September 2012
  96. *
  97. * .. Scalar Arguments ..
  98. CHARACTER ID
  99. INTEGER INFO, N
  100. * ..
  101. * .. Array Arguments ..
  102. REAL*8 D( * )
  103. * ..
  104. *
  105. * =====================================================================
  106. *
  107. * .. Parameters ..
  108. INTEGER SELECT
  109. PARAMETER ( SELECT = 20 )
  110. * ..
  111. * .. Local Scalars ..
  112. INTEGER DIR, ENDD, I, J, START, STKPNT
  113. REAL*8 D1, D2, D3, DMNMX, TMP
  114. * ..
  115. * .. Local Arrays ..
  116. INTEGER STACK( 2, 32 )
  117. * ..
  118. * .. External Functions ..
  119. LOGICAL LSAME
  120. EXTERNAL LSAME
  121. * ..
  122. * .. External Subroutines ..
  123. EXTERNAL XERBLA
  124. * ..
  125. * .. Executable Statements ..
  126. *
  127. * Test the input paramters.
  128. *
  129. INFO = 0
  130. DIR = -1
  131. IF( LSAME( ID, 'D' ) ) THEN
  132. DIR = 0
  133. ELSE IF( LSAME( ID, 'I' ) ) THEN
  134. DIR = 1
  135. END IF
  136. IF( DIR.EQ.-1 ) THEN
  137. INFO = -1
  138. ELSE IF( N.LT.0 ) THEN
  139. INFO = -2
  140. END IF
  141. IF( INFO.NE.0 ) THEN
  142. CALL XERBLA( 'DLASRT', -INFO )
  143. RETURN
  144. END IF
  145. *
  146. * Quick return if possible
  147. *
  148. IF( N.LE.1 )
  149. $ RETURN
  150. *
  151. STKPNT = 1
  152. STACK( 1, 1 ) = 1
  153. STACK( 2, 1 ) = N
  154. 10 CONTINUE
  155. START = STACK( 1, STKPNT )
  156. ENDD = STACK( 2, STKPNT )
  157. STKPNT = STKPNT - 1
  158. IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
  159. *
  160. * Do Insertion sort on D( START:ENDD )
  161. *
  162. IF( DIR.EQ.0 ) THEN
  163. *
  164. * Sort into decreasing order
  165. *
  166. DO 30 I = START + 1, ENDD
  167. DO 20 J = I, START + 1, -1
  168. IF( D( J ).GT.D( J-1 ) ) THEN
  169. DMNMX = D( J )
  170. D( J ) = D( J-1 )
  171. D( J-1 ) = DMNMX
  172. ELSE
  173. GO TO 30
  174. END IF
  175. 20 CONTINUE
  176. 30 CONTINUE
  177. *
  178. ELSE
  179. *
  180. * Sort into increasing order
  181. *
  182. DO 50 I = START + 1, ENDD
  183. DO 40 J = I, START + 1, -1
  184. IF( D( J ).LT.D( J-1 ) ) THEN
  185. DMNMX = D( J )
  186. D( J ) = D( J-1 )
  187. D( J-1 ) = DMNMX
  188. ELSE
  189. GO TO 50
  190. END IF
  191. 40 CONTINUE
  192. 50 CONTINUE
  193. *
  194. END IF
  195. *
  196. ELSE IF( ENDD-START.GT.SELECT ) THEN
  197. *
  198. * Partition D( START:ENDD ) and stack parts, largest one first
  199. *
  200. * Choose partition entry as median of 3
  201. *
  202. D1 = D( START )
  203. D2 = D( ENDD )
  204. I = ( START+ENDD ) / 2
  205. D3 = D( I )
  206. IF( D1.LT.D2 ) THEN
  207. IF( D3.LT.D1 ) THEN
  208. DMNMX = D1
  209. ELSE IF( D3.LT.D2 ) THEN
  210. DMNMX = D3
  211. ELSE
  212. DMNMX = D2
  213. END IF
  214. ELSE
  215. IF( D3.LT.D2 ) THEN
  216. DMNMX = D2
  217. ELSE IF( D3.LT.D1 ) THEN
  218. DMNMX = D3
  219. ELSE
  220. DMNMX = D1
  221. END IF
  222. END IF
  223. *
  224. IF( DIR.EQ.0 ) THEN
  225. *
  226. * Sort into decreasing order
  227. *
  228. I = START - 1
  229. J = ENDD + 1
  230. 60 CONTINUE
  231. 70 CONTINUE
  232. J = J - 1
  233. IF( D( J ).LT.DMNMX )
  234. $ GO TO 70
  235. 80 CONTINUE
  236. I = I + 1
  237. IF( D( I ).GT.DMNMX )
  238. $ GO TO 80
  239. IF( I.LT.J ) THEN
  240. TMP = D( I )
  241. D( I ) = D( J )
  242. D( J ) = TMP
  243. GO TO 60
  244. END IF
  245. IF( J-START.GT.ENDD-J-1 ) THEN
  246. STKPNT = STKPNT + 1
  247. STACK( 1, STKPNT ) = START
  248. STACK( 2, STKPNT ) = J
  249. STKPNT = STKPNT + 1
  250. STACK( 1, STKPNT ) = J + 1
  251. STACK( 2, STKPNT ) = ENDD
  252. ELSE
  253. STKPNT = STKPNT + 1
  254. STACK( 1, STKPNT ) = J + 1
  255. STACK( 2, STKPNT ) = ENDD
  256. STKPNT = STKPNT + 1
  257. STACK( 1, STKPNT ) = START
  258. STACK( 2, STKPNT ) = J
  259. END IF
  260. ELSE
  261. *
  262. * Sort into increasing order
  263. *
  264. I = START - 1
  265. J = ENDD + 1
  266. 90 CONTINUE
  267. 100 CONTINUE
  268. J = J - 1
  269. IF( D( J ).GT.DMNMX )
  270. $ GO TO 100
  271. 110 CONTINUE
  272. I = I + 1
  273. IF( D( I ).LT.DMNMX )
  274. $ GO TO 110
  275. IF( I.LT.J ) THEN
  276. TMP = D( I )
  277. D( I ) = D( J )
  278. D( J ) = TMP
  279. GO TO 90
  280. END IF
  281. IF( J-START.GT.ENDD-J-1 ) THEN
  282. STKPNT = STKPNT + 1
  283. STACK( 1, STKPNT ) = START
  284. STACK( 2, STKPNT ) = J
  285. STKPNT = STKPNT + 1
  286. STACK( 1, STKPNT ) = J + 1
  287. STACK( 2, STKPNT ) = ENDD
  288. ELSE
  289. STKPNT = STKPNT + 1
  290. STACK( 1, STKPNT ) = J + 1
  291. STACK( 2, STKPNT ) = ENDD
  292. STKPNT = STKPNT + 1
  293. STACK( 1, STKPNT ) = START
  294. STACK( 2, STKPNT ) = J
  295. END IF
  296. END IF
  297. END IF
  298. IF( STKPNT.GT.0 )
  299. $ GO TO 10
  300. RETURN
  301. *
  302. * End of DLASRT
  303. *
  304. END
  305.  
  306.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales