home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / octave-1.1.1p1-src.tgz / tar.out / fsf / octave / libcruft / lapack / dlascl.f < prev    next >
Text File  |  1996-09-28  |  7KB  |  269 lines
  1.       SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
  2. *
  3. *  -- LAPACK auxiliary routine (version 2.0) --
  4. *     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
  5. *     Courant Institute, Argonne National Lab, and Rice University
  6. *     February 29, 1992
  7. *
  8. *     .. Scalar Arguments ..
  9.       CHARACTER          TYPE
  10.       INTEGER            INFO, KL, KU, LDA, M, N
  11.       DOUBLE PRECISION   CFROM, CTO
  12. *     ..
  13. *     .. Array Arguments ..
  14.       DOUBLE PRECISION   A( LDA, * )
  15. *     ..
  16. *
  17. *  Purpose
  18. *  =======
  19. *
  20. *  DLASCL multiplies the M by N real matrix A by the real scalar
  21. *  CTO/CFROM.  This is done without over/underflow as long as the final
  22. *  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
  23. *  A may be full, upper triangular, lower triangular, upper Hessenberg,
  24. *  or banded.
  25. *
  26. *  Arguments
  27. *  =========
  28. *
  29. *  TYPE    (input) CHARACTER*1
  30. *          TYPE indices the storage type of the input matrix.
  31. *          = 'G':  A is a full matrix.
  32. *          = 'L':  A is a lower triangular matrix.
  33. *          = 'U':  A is an upper triangular matrix.
  34. *          = 'H':  A is an upper Hessenberg matrix.
  35. *          = 'B':  A is a symmetric band matrix with lower bandwidth KL
  36. *                  and upper bandwidth KU and with the only the lower
  37. *                  half stored.
  38. *          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
  39. *                  and upper bandwidth KU and with the only the upper
  40. *                  half stored.
  41. *          = 'Z':  A is a band matrix with lower bandwidth KL and upper
  42. *                  bandwidth KU.
  43. *
  44. *  KL      (input) INTEGER
  45. *          The lower bandwidth of A.  Referenced only if TYPE = 'B',
  46. *          'Q' or 'Z'.
  47. *
  48. *  KU      (input) INTEGER
  49. *          The upper bandwidth of A.  Referenced only if TYPE = 'B',
  50. *          'Q' or 'Z'.
  51. *
  52. *  CFROM   (input) DOUBLE PRECISION
  53. *  CTO     (input) DOUBLE PRECISION
  54. *          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
  55. *          without over/underflow if the final result CTO*A(I,J)/CFROM
  56. *          can be represented without over/underflow.  CFROM must be
  57. *          nonzero.
  58. *
  59. *  M       (input) INTEGER
  60. *          The number of rows of the matrix A.  M >= 0.
  61. *
  62. *  N       (input) INTEGER
  63. *          The number of columns of the matrix A.  N >= 0.
  64. *
  65. *  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
  66. *          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
  67. *          storage type.
  68. *
  69. *  LDA     (input) INTEGER
  70. *          The leading dimension of the array A.  LDA >= max(1,M).
  71. *
  72. *  INFO    (output) INTEGER
  73. *          0  - successful exit
  74. *          <0 - if INFO = -i, the i-th argument had an illegal value.
  75. *
  76. *  =====================================================================
  77. *
  78. *     .. Parameters ..
  79.       DOUBLE PRECISION   ZERO, ONE
  80.       PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
  81. *     ..
  82. *     .. Local Scalars ..
  83.       LOGICAL            DONE
  84.       INTEGER            I, ITYPE, J, K1, K2, K3, K4
  85.       DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
  86. *     ..
  87. *     .. External Functions ..
  88.       LOGICAL            LSAME
  89.       DOUBLE PRECISION   DLAMCH
  90.       EXTERNAL           LSAME, DLAMCH
  91. *     ..
  92. *     .. Intrinsic Functions ..
  93.       INTRINSIC          ABS, MAX, MIN
  94. *     ..
  95. *     .. External Subroutines ..
  96.       EXTERNAL           XERBLA
  97. *     ..
  98. *     .. Executable Statements ..
  99. *
  100. *     Test the input arguments
  101. *
  102.       INFO = 0
  103. *
  104.       IF( LSAME( TYPE, 'G' ) ) THEN
  105.          ITYPE = 0
  106.       ELSE IF( LSAME( TYPE, 'L' ) ) THEN
  107.          ITYPE = 1
  108.       ELSE IF( LSAME( TYPE, 'U' ) ) THEN
  109.          ITYPE = 2
  110.       ELSE IF( LSAME( TYPE, 'H' ) ) THEN
  111.          ITYPE = 3
  112.       ELSE IF( LSAME( TYPE, 'B' ) ) THEN
  113.          ITYPE = 4
  114.       ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
  115.          ITYPE = 5
  116.       ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
  117.          ITYPE = 6
  118.       ELSE
  119.          ITYPE = -1
  120.       END IF
  121. *
  122.       IF( ITYPE.EQ.-1 ) THEN
  123.          INFO = -1
  124.       ELSE IF( CFROM.EQ.ZERO ) THEN
  125.          INFO = -4
  126.       ELSE IF( M.LT.0 ) THEN
  127.          INFO = -6
  128.       ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
  129.      $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
  130.          INFO = -7
  131.       ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
  132.          INFO = -9
  133.       ELSE IF( ITYPE.GE.4 ) THEN
  134.          IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
  135.             INFO = -2
  136.          ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
  137.      $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
  138.      $             THEN
  139.             INFO = -3
  140.          ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
  141.      $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
  142.      $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
  143.             INFO = -9
  144.          END IF
  145.       END IF
  146. *
  147.       IF( INFO.NE.0 ) THEN
  148.          CALL XERBLA( 'DLASCL', -INFO )
  149.          RETURN
  150.       END IF
  151. *
  152. *     Quick return if possible
  153. *
  154.       IF( N.EQ.0 .OR. M.EQ.0 )
  155.      $   RETURN
  156. *
  157. *     Get machine parameters
  158. *
  159.       SMLNUM = DLAMCH( 'S' )
  160.       BIGNUM = ONE / SMLNUM
  161. *
  162.       CFROMC = CFROM
  163.       CTOC = CTO
  164. *
  165.    10 CONTINUE
  166.       CFROM1 = CFROMC*SMLNUM
  167.       CTO1 = CTOC / BIGNUM
  168.       IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
  169.          MUL = SMLNUM
  170.          DONE = .FALSE.
  171.          CFROMC = CFROM1
  172.       ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
  173.          MUL = BIGNUM
  174.          DONE = .FALSE.
  175.          CTOC = CTO1
  176.       ELSE
  177.          MUL = CTOC / CFROMC
  178.          DONE = .TRUE.
  179.       END IF
  180. *
  181.       IF( ITYPE.EQ.0 ) THEN
  182. *
  183. *        Full matrix
  184. *
  185.          DO 30 J = 1, N
  186.             DO 20 I = 1, M
  187.                A( I, J ) = A( I, J )*MUL
  188.    20       CONTINUE
  189.    30    CONTINUE
  190. *
  191.       ELSE IF( ITYPE.EQ.1 ) THEN
  192. *
  193. *        Lower triangular matrix
  194. *
  195.          DO 50 J = 1, N
  196.             DO 40 I = J, M
  197.                A( I, J ) = A( I, J )*MUL
  198.    40       CONTINUE
  199.    50    CONTINUE
  200. *
  201.       ELSE IF( ITYPE.EQ.2 ) THEN
  202. *
  203. *        Upper triangular matrix
  204. *
  205.          DO 70 J = 1, N
  206.             DO 60 I = 1, MIN( J, M )
  207.                A( I, J ) = A( I, J )*MUL
  208.    60       CONTINUE
  209.    70    CONTINUE
  210. *
  211.       ELSE IF( ITYPE.EQ.3 ) THEN
  212. *
  213. *        Upper Hessenberg matrix
  214. *
  215.          DO 90 J = 1, N
  216.             DO 80 I = 1, MIN( J+1, M )
  217.                A( I, J ) = A( I, J )*MUL
  218.    80       CONTINUE
  219.    90    CONTINUE
  220. *
  221.       ELSE IF( ITYPE.EQ.4 ) THEN
  222. *
  223. *        Lower half of a symmetric band matrix
  224. *
  225.          K3 = KL + 1
  226.          K4 = N + 1
  227.          DO 110 J = 1, N
  228.             DO 100 I = 1, MIN( K3, K4-J )
  229.                A( I, J ) = A( I, J )*MUL
  230.   100       CONTINUE
  231.   110    CONTINUE
  232. *
  233.       ELSE IF( ITYPE.EQ.5 ) THEN
  234. *
  235. *        Upper half of a symmetric band matrix
  236. *
  237.          K1 = KU + 2
  238.          K3 = KU + 1
  239.          DO 130 J = 1, N
  240.             DO 120 I = MAX( K1-J, 1 ), K3
  241.                A( I, J ) = A( I, J )*MUL
  242.   120       CONTINUE
  243.   130    CONTINUE
  244. *
  245.       ELSE IF( ITYPE.EQ.6 ) THEN
  246. *
  247. *        Band matrix
  248. *
  249.          K1 = KL + KU + 2
  250.          K2 = KL + 1
  251.          K3 = 2*KL + KU + 1
  252.          K4 = KL + KU + 1 + M
  253.          DO 150 J = 1, N
  254.             DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
  255.                A( I, J ) = A( I, J )*MUL
  256.   140       CONTINUE
  257.   150    CONTINUE
  258. *
  259.       END IF
  260. *
  261.       IF( .NOT.DONE )
  262.      $   GO TO 10
  263. *
  264.       RETURN
  265. *
  266. *     End of DLASCL
  267. *
  268.       END
  269.