Télécharger dsesrt.eso

Retour à la liste

Numérotation des lignes :

  1. C DSESRT SOURCE BP208322 15/10/13 21:15:53 8670
  2. c-----------------------------------------------------------------------
  3. c\BeginDoc
  4. c
  5. c\Name: dsesrt
  6. c
  7. c\Description:
  8. c Sort the array X in the order specified by WHICH and optionally
  9. c apply the permutation to the columns of the matrix A.
  10. c
  11. c\Usage:
  12. c call dsesrt
  13. c ( WHICH, APPLY, N, X, NA, A, LDA)
  14. c
  15. c\Arguments
  16. c WHICH Character*2. (Input)
  17. c 'LM' -> X is sorted into increasing order of magnitude.
  18. c 'SM' -> X is sorted into decreasing order of magnitude.
  19. c 'LA' -> X is sorted into increasing order of algebraic.
  20. c 'SA' -> X is sorted into decreasing order of algebraic.
  21. c
  22. c APPLY Logical. (Input)
  23. c APPLY = .TRUE. -> apply the sorted order to A.
  24. c APPLY = .FALSE. -> do not apply the sorted order to A.
  25. c
  26. c N Integer. (INPUT)
  27. c Dimension of the array X.
  28. c
  29. c X REAL*8 array of length N. (INPUT/OUTPUT)
  30. c The array to be sorted.
  31. c
  32. c NA Integer. (INPUT)
  33. c Number of rows of the matrix A.
  34. c
  35. c A REAL*8 array of length NA by N. (INPUT/OUTPUT)
  36. c
  37. c LDA Integer. (INPUT)
  38. c Leading dimension of A.
  39. c
  40. c\EndDoc
  41. c
  42. c-----------------------------------------------------------------------
  43. c
  44. c\BeginLib
  45. c
  46. c\Routines
  47. c dswap Level 1 BLAS that swaps the contents of two vectors.
  48. c
  49. c\Authors
  50. c Danny Sorensen Phuong Vu
  51. c Richard Lehoucq CRPC / Rice University
  52. c Dept. of Computational & Houston, Texas
  53. c Applied Mathematics
  54. c Rice University
  55. c Houston, Texas
  56. c
  57. c\Revision history:
  58. c 12/15/93: Version ' 2.1'.
  59. c Adapted from the sort routine in LANSO and
  60. c the ARPACK code dsortr
  61. c
  62. c\SCCS Information: @(#)
  63. c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2
  64. c
  65. c\EndLib
  66. c
  67. c-----------------------------------------------------------------------
  68. c
  69. subroutine dsesrt (which, apply, n, x, na, a, lda)
  70. c
  71. c %------------------%
  72. c | Scalar Arguments |
  73. c %------------------%
  74. c
  75. character*2 which
  76. logical apply
  77. integer lda, n, na
  78. c
  79. c %-----------------%
  80. c | Array Arguments |
  81. c %-----------------%
  82. c
  83. REAL*8
  84. & x(0:n-1), a(lda, 0:n-1)
  85. c
  86. c %---------------%
  87. c | Local Scalars |
  88. c %---------------%
  89. c
  90. integer i, igap, j
  91. REAL*8
  92. & temp
  93. c
  94. c %----------------------%
  95. c | External Subroutines |
  96. c %----------------------%
  97. c
  98. external dswap
  99. c
  100. c %-----------------------%
  101. c | Executable Statements |
  102. c %-----------------------%
  103. c
  104. igap = n / 2
  105. c
  106. if (which .eq. 'SA') then
  107. c
  108. c X is sorted into decreasing order of algebraic.
  109. c
  110. 10 continue
  111. if (igap .eq. 0) go to 9000
  112. do 30 i = igap, n-1
  113. j = i-igap
  114. 20 continue
  115. c
  116. if (j.lt.0) go to 30
  117. c
  118. if (x(j).lt.x(j+igap)) then
  119. temp = x(j)
  120. x(j) = x(j+igap)
  121. x(j+igap) = temp
  122. if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
  123. else
  124. go to 30
  125. endif
  126. j = j-igap
  127. go to 20
  128. 30 continue
  129. igap = igap / 2
  130. go to 10
  131. c
  132. else if (which .eq. 'SM') then
  133. c
  134. c X is sorted into decreasing order of magnitude.
  135. c
  136. 40 continue
  137. if (igap .eq. 0) go to 9000
  138. do 60 i = igap, n-1
  139. j = i-igap
  140. 50 continue
  141. c
  142. if (j.lt.0) go to 60
  143. c
  144. if (abs(x(j)).lt.abs(x(j+igap))) then
  145. temp = x(j)
  146. x(j) = x(j+igap)
  147. x(j+igap) = temp
  148. if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
  149. else
  150. go to 60
  151. endif
  152. j = j-igap
  153. go to 50
  154. 60 continue
  155. igap = igap / 2
  156. go to 40
  157. c
  158. else if (which .eq. 'LA') then
  159. c
  160. c X is sorted into increasing order of algebraic.
  161. c
  162. 70 continue
  163. if (igap .eq. 0) go to 9000
  164. do 90 i = igap, n-1
  165. j = i-igap
  166. 80 continue
  167. c
  168. if (j.lt.0) go to 90
  169. c
  170. if (x(j).gt.x(j+igap)) then
  171. temp = x(j)
  172. x(j) = x(j+igap)
  173. x(j+igap) = temp
  174. if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
  175. else
  176. go to 90
  177. endif
  178. j = j-igap
  179. go to 80
  180. 90 continue
  181. igap = igap / 2
  182. go to 70
  183. c
  184. else if (which .eq. 'LM') then
  185. c
  186. c X is sorted into increasing order of magnitude.
  187. c
  188. 100 continue
  189. if (igap .eq. 0) go to 9000
  190. do 120 i = igap, n-1
  191. j = i-igap
  192. 110 continue
  193. c
  194. if (j.lt.0) go to 120
  195. c
  196. if (abs(x(j)).gt.abs(x(j+igap))) then
  197. temp = x(j)
  198. x(j) = x(j+igap)
  199. x(j+igap) = temp
  200. if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
  201. else
  202. go to 120
  203. endif
  204. j = j-igap
  205. go to 110
  206. 120 continue
  207. igap = igap / 2
  208. go to 100
  209. end if
  210. c
  211. 9000 continue
  212. return
  213. c
  214. c %---------------%
  215. c | End of dsesrt |
  216. c %---------------%
  217. c
  218. end
  219.  
  220.  

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