You can not select more than 25 topics Topics must start with a chinese character,a letter or number, can include dashes ('-') and can be up to 35 characters long.

stpsv.f 11 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354
  1. *> \brief \b STPSV
  2. *
  3. * =========== DOCUMENTATION ===========
  4. *
  5. * Online html documentation available at
  6. * http://www.netlib.org/lapack/explore-html/
  7. *
  8. * Definition:
  9. * ===========
  10. *
  11. * SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
  12. *
  13. * .. Scalar Arguments ..
  14. * INTEGER INCX,N
  15. * CHARACTER DIAG,TRANS,UPLO
  16. * ..
  17. * .. Array Arguments ..
  18. * REAL AP(*),X(*)
  19. * ..
  20. *
  21. *
  22. *> \par Purpose:
  23. * =============
  24. *>
  25. *> \verbatim
  26. *>
  27. *> STPSV solves one of the systems of equations
  28. *>
  29. *> A*x = b, or A**T*x = b,
  30. *>
  31. *> where b and x are n element vectors and A is an n by n unit, or
  32. *> non-unit, upper or lower triangular matrix, supplied in packed form.
  33. *>
  34. *> No test for singularity or near-singularity is included in this
  35. *> routine. Such tests must be performed before calling this routine.
  36. *> \endverbatim
  37. *
  38. * Arguments:
  39. * ==========
  40. *
  41. *> \param[in] UPLO
  42. *> \verbatim
  43. *> UPLO is CHARACTER*1
  44. *> On entry, UPLO specifies whether the matrix is an upper or
  45. *> lower triangular matrix as follows:
  46. *>
  47. *> UPLO = 'U' or 'u' A is an upper triangular matrix.
  48. *>
  49. *> UPLO = 'L' or 'l' A is a lower triangular matrix.
  50. *> \endverbatim
  51. *>
  52. *> \param[in] TRANS
  53. *> \verbatim
  54. *> TRANS is CHARACTER*1
  55. *> On entry, TRANS specifies the equations to be solved as
  56. *> follows:
  57. *>
  58. *> TRANS = 'N' or 'n' A*x = b.
  59. *>
  60. *> TRANS = 'T' or 't' A**T*x = b.
  61. *>
  62. *> TRANS = 'C' or 'c' A**T*x = b.
  63. *> \endverbatim
  64. *>
  65. *> \param[in] DIAG
  66. *> \verbatim
  67. *> DIAG is CHARACTER*1
  68. *> On entry, DIAG specifies whether or not A is unit
  69. *> triangular as follows:
  70. *>
  71. *> DIAG = 'U' or 'u' A is assumed to be unit triangular.
  72. *>
  73. *> DIAG = 'N' or 'n' A is not assumed to be unit
  74. *> triangular.
  75. *> \endverbatim
  76. *>
  77. *> \param[in] N
  78. *> \verbatim
  79. *> N is INTEGER
  80. *> On entry, N specifies the order of the matrix A.
  81. *> N must be at least zero.
  82. *> \endverbatim
  83. *>
  84. *> \param[in] AP
  85. *> \verbatim
  86. *> AP is REAL array, dimension at least
  87. *> ( ( n*( n + 1 ) )/2 ).
  88. *> Before entry with UPLO = 'U' or 'u', the array AP must
  89. *> contain the upper triangular matrix packed sequentially,
  90. *> column by column, so that AP( 1 ) contains a( 1, 1 ),
  91. *> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
  92. *> respectively, and so on.
  93. *> Before entry with UPLO = 'L' or 'l', the array AP must
  94. *> contain the lower triangular matrix packed sequentially,
  95. *> column by column, so that AP( 1 ) contains a( 1, 1 ),
  96. *> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
  97. *> respectively, and so on.
  98. *> Note that when DIAG = 'U' or 'u', the diagonal elements of
  99. *> A are not referenced, but are assumed to be unity.
  100. *> \endverbatim
  101. *>
  102. *> \param[in,out] X
  103. *> \verbatim
  104. *> X is REAL array, dimension at least
  105. *> ( 1 + ( n - 1 )*abs( INCX ) ).
  106. *> Before entry, the incremented array X must contain the n
  107. *> element right-hand side vector b. On exit, X is overwritten
  108. *> with the solution vector x.
  109. *> \endverbatim
  110. *>
  111. *> \param[in] INCX
  112. *> \verbatim
  113. *> INCX is INTEGER
  114. *> On entry, INCX specifies the increment for the elements of
  115. *> X. INCX must not be zero.
  116. *> \endverbatim
  117. *
  118. * Authors:
  119. * ========
  120. *
  121. *> \author Univ. of Tennessee
  122. *> \author Univ. of California Berkeley
  123. *> \author Univ. of Colorado Denver
  124. *> \author NAG Ltd.
  125. *
  126. *> \date December 2016
  127. *
  128. *> \ingroup single_blas_level2
  129. *
  130. *> \par Further Details:
  131. * =====================
  132. *>
  133. *> \verbatim
  134. *>
  135. *> Level 2 Blas routine.
  136. *>
  137. *> -- Written on 22-October-1986.
  138. *> Jack Dongarra, Argonne National Lab.
  139. *> Jeremy Du Croz, Nag Central Office.
  140. *> Sven Hammarling, Nag Central Office.
  141. *> Richard Hanson, Sandia National Labs.
  142. *> \endverbatim
  143. *>
  144. * =====================================================================
  145. SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
  146. *
  147. * -- Reference BLAS level2 routine (version 3.7.0) --
  148. * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
  149. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  150. * December 2016
  151. *
  152. * .. Scalar Arguments ..
  153. INTEGER INCX,N
  154. CHARACTER DIAG,TRANS,UPLO
  155. * ..
  156. * .. Array Arguments ..
  157. REAL AP(*),X(*)
  158. * ..
  159. *
  160. * =====================================================================
  161. *
  162. * .. Parameters ..
  163. REAL ZERO
  164. PARAMETER (ZERO=0.0E+0)
  165. * ..
  166. * .. Local Scalars ..
  167. REAL TEMP
  168. INTEGER I,INFO,IX,J,JX,K,KK,KX
  169. LOGICAL NOUNIT
  170. * ..
  171. * .. External Functions ..
  172. LOGICAL LSAME
  173. EXTERNAL LSAME
  174. * ..
  175. * .. External Subroutines ..
  176. EXTERNAL XERBLA
  177. * ..
  178. *
  179. * Test the input parameters.
  180. *
  181. INFO = 0
  182. IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
  183. INFO = 1
  184. ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
  185. + .NOT.LSAME(TRANS,'C')) THEN
  186. INFO = 2
  187. ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
  188. INFO = 3
  189. ELSE IF (N.LT.0) THEN
  190. INFO = 4
  191. ELSE IF (INCX.EQ.0) THEN
  192. INFO = 7
  193. END IF
  194. IF (INFO.NE.0) THEN
  195. CALL XERBLA('STPSV ',INFO)
  196. RETURN
  197. END IF
  198. *
  199. * Quick return if possible.
  200. *
  201. IF (N.EQ.0) RETURN
  202. *
  203. NOUNIT = LSAME(DIAG,'N')
  204. *
  205. * Set up the start point in X if the increment is not unity. This
  206. * will be ( N - 1 )*INCX too small for descending loops.
  207. *
  208. IF (INCX.LE.0) THEN
  209. KX = 1 - (N-1)*INCX
  210. ELSE IF (INCX.NE.1) THEN
  211. KX = 1
  212. END IF
  213. *
  214. * Start the operations. In this version the elements of AP are
  215. * accessed sequentially with one pass through AP.
  216. *
  217. IF (LSAME(TRANS,'N')) THEN
  218. *
  219. * Form x := inv( A )*x.
  220. *
  221. IF (LSAME(UPLO,'U')) THEN
  222. KK = (N* (N+1))/2
  223. IF (INCX.EQ.1) THEN
  224. DO 20 J = N,1,-1
  225. IF (X(J).NE.ZERO) THEN
  226. IF (NOUNIT) X(J) = X(J)/AP(KK)
  227. TEMP = X(J)
  228. K = KK - 1
  229. DO 10 I = J - 1,1,-1
  230. X(I) = X(I) - TEMP*AP(K)
  231. K = K - 1
  232. 10 CONTINUE
  233. END IF
  234. KK = KK - J
  235. 20 CONTINUE
  236. ELSE
  237. JX = KX + (N-1)*INCX
  238. DO 40 J = N,1,-1
  239. IF (X(JX).NE.ZERO) THEN
  240. IF (NOUNIT) X(JX) = X(JX)/AP(KK)
  241. TEMP = X(JX)
  242. IX = JX
  243. DO 30 K = KK - 1,KK - J + 1,-1
  244. IX = IX - INCX
  245. X(IX) = X(IX) - TEMP*AP(K)
  246. 30 CONTINUE
  247. END IF
  248. JX = JX - INCX
  249. KK = KK - J
  250. 40 CONTINUE
  251. END IF
  252. ELSE
  253. KK = 1
  254. IF (INCX.EQ.1) THEN
  255. DO 60 J = 1,N
  256. IF (X(J).NE.ZERO) THEN
  257. IF (NOUNIT) X(J) = X(J)/AP(KK)
  258. TEMP = X(J)
  259. K = KK + 1
  260. DO 50 I = J + 1,N
  261. X(I) = X(I) - TEMP*AP(K)
  262. K = K + 1
  263. 50 CONTINUE
  264. END IF
  265. KK = KK + (N-J+1)
  266. 60 CONTINUE
  267. ELSE
  268. JX = KX
  269. DO 80 J = 1,N
  270. IF (X(JX).NE.ZERO) THEN
  271. IF (NOUNIT) X(JX) = X(JX)/AP(KK)
  272. TEMP = X(JX)
  273. IX = JX
  274. DO 70 K = KK + 1,KK + N - J
  275. IX = IX + INCX
  276. X(IX) = X(IX) - TEMP*AP(K)
  277. 70 CONTINUE
  278. END IF
  279. JX = JX + INCX
  280. KK = KK + (N-J+1)
  281. 80 CONTINUE
  282. END IF
  283. END IF
  284. ELSE
  285. *
  286. * Form x := inv( A**T )*x.
  287. *
  288. IF (LSAME(UPLO,'U')) THEN
  289. KK = 1
  290. IF (INCX.EQ.1) THEN
  291. DO 100 J = 1,N
  292. TEMP = X(J)
  293. K = KK
  294. DO 90 I = 1,J - 1
  295. TEMP = TEMP - AP(K)*X(I)
  296. K = K + 1
  297. 90 CONTINUE
  298. IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
  299. X(J) = TEMP
  300. KK = KK + J
  301. 100 CONTINUE
  302. ELSE
  303. JX = KX
  304. DO 120 J = 1,N
  305. TEMP = X(JX)
  306. IX = KX
  307. DO 110 K = KK,KK + J - 2
  308. TEMP = TEMP - AP(K)*X(IX)
  309. IX = IX + INCX
  310. 110 CONTINUE
  311. IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
  312. X(JX) = TEMP
  313. JX = JX + INCX
  314. KK = KK + J
  315. 120 CONTINUE
  316. END IF
  317. ELSE
  318. KK = (N* (N+1))/2
  319. IF (INCX.EQ.1) THEN
  320. DO 140 J = N,1,-1
  321. TEMP = X(J)
  322. K = KK
  323. DO 130 I = N,J + 1,-1
  324. TEMP = TEMP - AP(K)*X(I)
  325. K = K - 1
  326. 130 CONTINUE
  327. IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
  328. X(J) = TEMP
  329. KK = KK - (N-J+1)
  330. 140 CONTINUE
  331. ELSE
  332. KX = KX + (N-1)*INCX
  333. JX = KX
  334. DO 160 J = N,1,-1
  335. TEMP = X(JX)
  336. IX = KX
  337. DO 150 K = KK,KK - (N- (J+1)),-1
  338. TEMP = TEMP - AP(K)*X(IX)
  339. IX = IX - INCX
  340. 150 CONTINUE
  341. IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
  342. X(JX) = TEMP
  343. JX = JX - INCX
  344. KK = KK - (N-J+1)
  345. 160 CONTINUE
  346. END IF
  347. END IF
  348. END IF
  349. *
  350. RETURN
  351. *
  352. * End of STPSV .
  353. *
  354. END