Télécharger dsortr.eso

Retour à la liste

Numérotation des lignes :

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

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