C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE MB01QD( TYPE, M, N, KL, KU, CFROM, CTO, NBL, NROWS, A,
     $                   LDA, INFO )
C
C     PURPOSE
C
C     To multiply the M by N real matrix A by the real scalar CTO/CFROM.
C     This is done without over/underflow as long as the final result
C     CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
C     A may be full, (block) upper triangular, (block) lower triangular,
C     (block) upper Hessenberg, or banded.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPE    CHARACTER*1
C             TYPE indices the storage type of the input matrix.
C             = 'G':  A is a full matrix.
C             = 'L':  A is a (block) lower triangular matrix.
C             = 'U':  A is a (block) upper triangular matrix.
C             = 'H':  A is a (block) upper Hessenberg matrix.
C             = 'B':  A is a symmetric band matrix with lower bandwidth
C                     KL and upper bandwidth KU and with the only the
C                     lower half stored.
C             = 'Q':  A is a symmetric band matrix with lower bandwidth
C                     KL and upper bandwidth KU and with the only the
C                     upper half stored.
C             = 'Z':  A is a band matrix with lower bandwidth KL and
C                     upper bandwidth KU.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     KL      (input) INTEGER
C             The lower bandwidth of A.  Referenced only if TYPE = 'B',
C             'Q' or 'Z'.
C
C     KU      (input) INTEGER
C             The upper bandwidth of A.  Referenced only if TYPE = 'B',
C             'Q' or 'Z'.
C
C     CFROM   (input) DOUBLE PRECISION
C     CTO     (input) DOUBLE PRECISION
C             The matrix A is multiplied by CTO/CFROM. A(I,J) is
C             computed without over/underflow if the final result
C             CTO*A(I,J)/CFROM can be represented without over/
C             underflow.  CFROM must be nonzero.
C
C     NBL     (input) INTEGER
C             The number of diagonal blocks of the matrix A, if it has a
C             block structure.  To specify that matrix A has no block
C             structure, set NBL = 0.  NBL >= 0.
C
C     NROWS   (input) INTEGER array, dimension max(1,NBL)
C             NROWS(i) contains the number of rows and columns of the
C             i-th diagonal block of matrix A.  The sum of the values
C             NROWS(i),  for  i = 1: NBL,  should be equal to min(M,N).
C             The array  NROWS  is not referenced if NBL = 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             The matrix to be multiplied by CTO/CFROM.  See TYPE for
C             the storage type.
C
C     LDA     (input) INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     Error Indicator
C
C     INFO    INTEGER
C             Not used in this implementation.
C
C     METHOD
C
C     Matrix A is multiplied by the real scalar CTO/CFROM, taking into
C     account the specified storage mode of the matrix.
C     MB01QD is a version of the LAPACK routine DLASCL, modified for
C     dealing with block triangular, or block Hessenberg matrices.
C     For efficiency, no tests of the input scalar parameters are
C     performed.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996.
C
C    ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          TYPE
      INTEGER            INFO, KL, KU, LDA, M, N, NBL
      DOUBLE PRECISION   CFROM, CTO
C     ..
C     .. Array Arguments ..
      INTEGER            NROWS ( * )
      DOUBLE PRECISION   A( LDA, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            DONE, NOBLC
      INTEGER            I, IFIN, ITYPE, J, JFIN, JINI, K, K1, K2, K3,
     $                   K4
      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      IF( LSAME( TYPE, 'G' ) ) THEN
         ITYPE = 0
      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
         ITYPE = 1
      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
         ITYPE = 2
      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
         ITYPE = 3
      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
         ITYPE = 4
      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
         ITYPE = 5
      ELSE
         ITYPE = 6
      END IF
C
C     Quick return if possible.
C
      IF( MIN( M, N ).EQ.0 )
     $   RETURN
C
C     Get machine parameters.
C
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
C
      CFROMC = CFROM
      CTOC = CTO
C
   10 CONTINUE
      CFROM1 = CFROMC*SMLNUM
      CTO1 = CTOC / BIGNUM
      IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
         MUL = SMLNUM
         DONE = .FALSE.
         CFROMC = CFROM1
      ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
         MUL = BIGNUM
         DONE = .FALSE.
         CTOC = CTO1
      ELSE
         MUL = CTOC / CFROMC
         DONE = .TRUE.
      END IF
C
      NOBLC = NBL.EQ.0
C
      IF( ITYPE.EQ.0 ) THEN
C
C        Full matrix
C
         DO 30 J = 1, N
            DO 20 I = 1, M
               A( I, J ) = A( I, J )*MUL
   20       CONTINUE
   30    CONTINUE
C
      ELSE IF( ITYPE.EQ.1 ) THEN
C
         IF ( NOBLC ) THEN
C
C           Lower triangular matrix
C
            DO 50 J = 1, N
               DO 40 I = J, M
                  A( I, J ) = A( I, J )*MUL
   40          CONTINUE
   50       CONTINUE
C
         ELSE
C
C           Block lower triangular matrix
C
            JFIN = 0
            DO 80 K = 1, NBL
               JINI = JFIN + 1
               JFIN = JFIN + NROWS( K )
               DO 70 J = JINI, JFIN
                  DO 60 I = JINI, M
                     A( I, J ) = A( I, J )*MUL
   60             CONTINUE
   70          CONTINUE
   80       CONTINUE
         END IF
C
      ELSE IF( ITYPE.EQ.2 ) THEN
C
         IF ( NOBLC ) THEN
C
C           Upper triangular matrix
C
            DO 100 J = 1, N
               DO 90 I = 1, MIN( J, M )
                  A( I, J ) = A( I, J )*MUL
   90          CONTINUE
  100       CONTINUE
C
         ELSE
C
C           Block upper triangular matrix
C
            JFIN = 0
            DO 130 K = 1, NBL
               JINI = JFIN + 1
               JFIN = JFIN + NROWS( K )
               IF ( K.EQ.NBL ) JFIN = N
               DO 120 J = JINI, JFIN
                  DO 110 I = 1, MIN( JFIN, M )
                     A( I, J ) = A( I, J )*MUL
  110             CONTINUE
  120          CONTINUE
  130       CONTINUE
         END IF
C
      ELSE IF( ITYPE.EQ.3 ) THEN
C
         IF ( NOBLC ) THEN
C
C           Upper Hessenberg matrix
C
            DO 150 J = 1, N
               DO 140 I = 1, MIN( J+1, M )
                  A( I, J ) = A( I, J )*MUL
  140          CONTINUE
  150       CONTINUE
C
         ELSE
C
C           Block upper Hessenberg matrix
C
            JFIN = 0
            DO 180 K = 1, NBL
               JINI = JFIN + 1
               JFIN = JFIN + NROWS( K )
C
               IF ( K.EQ.NBL ) THEN
                  JFIN = N
                  IFIN = N
               ELSE
                  IFIN = JFIN + NROWS( K+1 )
               END IF
C
               DO 170 J = JINI, JFIN
                  DO 160 I = 1, MIN( IFIN, M )
                     A( I, J ) = A( I, J )*MUL
  160             CONTINUE
  170          CONTINUE
  180       CONTINUE
         END IF
C
      ELSE IF( ITYPE.EQ.4 ) THEN
C
C        Lower half of a symmetric band matrix
C
         K3 = KL + 1
         K4 = N + 1
         DO 200 J = 1, N
            DO 190 I = 1, MIN( K3, K4-J )
               A( I, J ) = A( I, J )*MUL
  190       CONTINUE
  200    CONTINUE
C
      ELSE IF( ITYPE.EQ.5 ) THEN
C
C        Upper half of a symmetric band matrix
C
         K1 = KU + 2
         K3 = KU + 1
         DO 220 J = 1, N
            DO 210 I = MAX( K1-J, 1 ), K3
               A( I, J ) = A( I, J )*MUL
  210       CONTINUE
  220    CONTINUE
C
      ELSE IF( ITYPE.EQ.6 ) THEN
C
C        Band matrix
C
         K1 = KL + KU + 2
         K2 = KL + 1
         K3 = 2*KL + KU + 1
         K4 = KL + KU + 1 + M
         DO 240 J = 1, N
            DO 230 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
               A( I, J ) = A( I, J )*MUL
  230       CONTINUE
  240    CONTINUE
C
      END IF
C
      IF( .NOT.DONE )
     $   GO TO 10
C
      RETURN
C *** Last line of MB01QD ***
      END
