Télécharger dlartg.eso

Retour à la liste

Numérotation des lignes :

  1. C DLARTG SOURCE BP208322 15/12/17 21:15:05 8750
  2. *> \brief \b DLARTG generates a plane rotation with real cosine and real sine.
  3. *
  4. * =========== DOCUMENTATION ===========
  5. *
  6. * Online html documentation available at
  7. * http://www.netlib.org/lapack/explore-html/
  8. *
  9. *> \htmlonly
  10. *> Download DLARTG + dependencies
  11. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlartg.f">
  12. *> [TGZ]</a>
  13. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlartg.f">
  14. *> [ZIP]</a>
  15. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlartg.f">
  16. *> [TXT]</a>
  17. *> \endhtmlonly
  18. *
  19. * Definition:
  20. * ===========
  21. *
  22. * SUBROUTINE DLARTG( F, G, CS, SN, R )
  23. *
  24. * .. Scalar Arguments ..
  25. * REAL*8 CS, F, G, R, SN
  26. * ..
  27. *
  28. *
  29. *> \par Purpose:
  30. * =============
  31. *>
  32. *> \verbatim
  33. *>
  34. *> DLARTG generate a plane rotation so that
  35. *>
  36. *> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
  37. *> [ -SN CS ] [ G ] [ 0 ]
  38. *>
  39. *> This is a slower, more accurate version of the BLAS1 routine DROTG,
  40. *> with the following other differences:
  41. *> F and G are unchanged on return.
  42. *> If G=0, then CS=1 and SN=0.
  43. *> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
  44. *> floating point operations (saves work in DBDSQR when
  45. *> there are zeros on the diagonal).
  46. *>
  47. *> If F exceeds G in magnitude, CS will be positive.
  48. *> \endverbatim
  49. *
  50. * Arguments:
  51. * ==========
  52. *
  53. *> \param[in] F
  54. *> \verbatim
  55. *> F is DOUBLE PRECISION
  56. *> The first component of vector to be rotated.
  57. *> \endverbatim
  58. *>
  59. *> \param[in] G
  60. *> \verbatim
  61. *> G is DOUBLE PRECISION
  62. *> The second component of vector to be rotated.
  63. *> \endverbatim
  64. *>
  65. *> \param[out] CS
  66. *> \verbatim
  67. *> CS is DOUBLE PRECISION
  68. *> The cosine of the rotation.
  69. *> \endverbatim
  70. *>
  71. *> \param[out] SN
  72. *> \verbatim
  73. *> SN is DOUBLE PRECISION
  74. *> The sine of the rotation.
  75. *> \endverbatim
  76. *>
  77. *> \param[out] R
  78. *> \verbatim
  79. *> R is DOUBLE PRECISION
  80. *> The nonzero component of the rotated vector.
  81. *>
  82. *> This version has a few statements commented out for thread safety
  83. *> (machine parameters are computed on each entry). 10 feb 03, SJH.
  84. *> \endverbatim
  85. *
  86. * Authors:
  87. * ========
  88. *
  89. *> \author Univ. of Tennessee
  90. *> \author Univ. of California Berkeley
  91. *> \author Univ. of Colorado Denver
  92. *> \author NAG Ltd.
  93. *
  94. *> \date September 2012
  95. *
  96. *> \ingroup auxOTHERauxiliary
  97. *
  98. * =====================================================================
  99. SUBROUTINE DLARTG( F, G, CS, SN, R )
  100. *
  101. * -- LAPACK auxiliary routine (version 3.4.2) --
  102. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  103. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  104. * September 2012
  105. *
  106. * .. Scalar Arguments ..
  107. REAL*8 CS, F, G, R, SN
  108. * ..
  109. *
  110. * =====================================================================
  111. *
  112. * .. Parameters ..
  113. REAL*8 ZERO
  114. PARAMETER ( ZERO = 0.0D0 )
  115. REAL*8 ONE
  116. PARAMETER ( ONE = 1.0D0 )
  117. REAL*8 TWO
  118. PARAMETER ( TWO = 2.0D0 )
  119. * ..
  120. * .. Local Scalars ..
  121. LOGICAL FIRST
  122. INTEGER COUNT, I
  123. REAL*8 EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
  124. * ..
  125. * .. External Functions ..
  126. REAL*8 DLAMCH
  127. EXTERNAL DLAMCH
  128. * ..
  129. ** .. Intrinsic Functions ..
  130. * INTRINSIC ABS, INT, LOG, MAX, SQRT
  131. ** ..
  132. ** .. Save statement ..
  133. SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
  134. ** ..
  135. ** .. Data statements ..
  136. DATA FIRST / .TRUE. /
  137. ** ..
  138. ** .. Executable Statements ..
  139. *
  140. IF( FIRST ) THEN
  141. SAFMIN = DLAMCH( 'S' )
  142. EPS = DLAMCH( 'E' )
  143. SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
  144. $ LOG( DLAMCH( 'B' ) ) / TWO )
  145. SAFMX2 = ONE / SAFMN2
  146. FIRST = .FALSE.
  147. END IF
  148. IF( G.EQ.ZERO ) THEN
  149. CS = ONE
  150. SN = ZERO
  151. R = F
  152. ELSE IF( F.EQ.ZERO ) THEN
  153. CS = ZERO
  154. SN = ONE
  155. R = G
  156. ELSE
  157. F1 = F
  158. G1 = G
  159. SCALE = MAX( ABS( F1 ), ABS( G1 ) )
  160. IF( SCALE.GE.SAFMX2 ) THEN
  161. COUNT = 0
  162. 10 CONTINUE
  163. COUNT = COUNT + 1
  164. F1 = F1*SAFMN2
  165. G1 = G1*SAFMN2
  166. SCALE = MAX( ABS( F1 ), ABS( G1 ) )
  167. IF( SCALE.GE.SAFMX2 )
  168. $ GO TO 10
  169. R = SQRT( F1**2+G1**2 )
  170. CS = F1 / R
  171. SN = G1 / R
  172. DO 20 I = 1, COUNT
  173. R = R*SAFMX2
  174. 20 CONTINUE
  175. ELSE IF( SCALE.LE.SAFMN2 ) THEN
  176. COUNT = 0
  177. 30 CONTINUE
  178. COUNT = COUNT + 1
  179. F1 = F1*SAFMX2
  180. G1 = G1*SAFMX2
  181. SCALE = MAX( ABS( F1 ), ABS( G1 ) )
  182. IF( SCALE.LE.SAFMN2 )
  183. $ GO TO 30
  184. R = SQRT( F1**2+G1**2 )
  185. CS = F1 / R
  186. SN = G1 / R
  187. DO 40 I = 1, COUNT
  188. R = R*SAFMN2
  189. 40 CONTINUE
  190. ELSE
  191. R = SQRT( F1**2+G1**2 )
  192. CS = F1 / R
  193. SN = G1 / R
  194. END IF
  195. IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
  196. CS = -CS
  197. SN = -SN
  198. R = -R
  199. END IF
  200. END IF
  201. RETURN
  202. *
  203. * End of DLARTG
  204. *
  205. END
  206.  
  207.  
  208.  

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