C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE MB01YD( UPLO, TRANS, N, K, L, ALPHA, BETA, A, LDA, C,
     $                   LDC, INFO )
C
C     PURPOSE
C
C     To perform the symmetric rank k operations
C
C        C := alpha*op( A )*op( A )' + beta*C,
C
C     where alpha and beta are scalars, C is an n-by-n symmetric matrix,
C     op( A ) is an n-by-k matrix, and op( A ) is one of
C
C        op( A ) = A   or   op( A ) = A'.
C
C     The matrix A has l nonzero codiagonals, either upper or lower.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the symmetric matrix C
C             is given and computed, as follows:
C             = 'U':  the upper triangular part is given/computed;
C             = 'L':  the lower triangular part is given/computed.
C             UPLO also defines the pattern of the matrix A (see below).
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( A ) to be used, as follows:
C             = 'N':  op( A ) = A;
C             = 'T':  op( A ) = A';
C             = 'C':  op( A ) = A'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix C.  N >= 0.
C
C     K       (input) INTEGER
C             The number of columns of the matrix op( A ).  K >= 0.
C
C     L       (input) INTEGER
C             If UPLO = 'U', matrix A has L nonzero subdiagonals.
C             If UPLO = 'L', matrix A has L nonzero superdiagonals.
C             MAX(0,NR-1) >= L >= 0, if UPLO = 'U',
C             MAX(0,NC-1) >= L >= 0, if UPLO = 'L',
C             where NR and NC are the numbers of rows and columns of the
C             matrix A, respectively.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then the array A is
C             not referenced.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then the array C need
C             not be set before entry.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,NC), where
C             NC is K when TRANS = 'N', and is N otherwise.
C             If TRANS = 'N', the leading N-by-K part of this array must
C             contain the matrix A, otherwise the leading K-by-N part of
C             this array must contain the matrix A.
C             If UPLO = 'U', only the upper triangular part and the
C             first L subdiagonals are referenced, and the remaining
C             subdiagonals are assumed to be zero.
C             If UPLO = 'L', only the lower triangular part and the
C             first L superdiagonals are referenced, and the remaining
C             superdiagonals are assumed to be zero.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= max(1,NR),
C             where NR = N, if TRANS = 'N', and NR = K, otherwise.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry with UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix C.
C             On entry with UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix C.
C             On exit, the leading N-by-N upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
C             this array contains the corresponding triangular part of
C             the updated matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The calculations are efficiently performed taking the symmetry
C     and structure into account.
C
C     FURTHER COMMENTS
C
C     The matrix A may have the following patterns, when n = 7, k = 5,
C     and l = 2 are used for illustration:
C
C     UPLO = 'U', TRANS = 'N'         UPLO = 'L', TRANS = 'N'
C
C            [ x x x x x ]                   [ x x x 0 0 ]
C            [ x x x x x ]                   [ x x x x 0 ]
C            [ x x x x x ]                   [ x x x x x ]
C        A = [ 0 x x x x ],              A = [ x x x x x ],
C            [ 0 0 x x x ]                   [ x x x x x ]
C            [ 0 0 0 x x ]                   [ x x x x x ]
C            [ 0 0 0 0 x ]                   [ x x x x x ]
C
C     UPLO = 'U', TRANS = 'T'         UPLO = 'L', TRANS = 'T'
C
C            [ x x x x x x x ]               [ x x x 0 0 0 0 ]
C            [ x x x x x x x ]               [ x x x x 0 0 0 ]
C        A = [ x x x x x x x ],          A = [ x x x x x 0 0 ].
C            [ 0 x x x x x x ]               [ x x x x x x 0 ]
C            [ 0 0 x x x x x ]               [ x x x x x x x ]
C
C     If N = K, the matrix A is upper or lower triangular, for L = 0,
C     and upper or lower Hessenberg, for L = 1.
C
C     This routine is a specialization of the BLAS 3 routine DSYRK.
C     BLAS 1 calls are used when appropriate, instead of in-line code,
C     in order to increase the efficiency. If the matrix A is full, or
C     its zero triangle has small order, an optimized DSYRK code could
C     be faster than MB01YD.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          TRANS, UPLO
      INTEGER            INFO, LDA, LDC, K, L, N
      DOUBLE PRECISION   ALPHA, BETA
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            TRANSP, UPPER
      INTEGER            I, J, M, NCOLA, NROWA
      DOUBLE PRECISION   TEMP
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           DDOT, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DLASCL, DLASET, DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      UPPER  = LSAME( UPLO,  'U' )
      TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF( TRANSP )THEN
         NROWA = K
         NCOLA = N
      ELSE
         NROWA = N
         NCOLA = K
      END IF
C
      IF( UPPER )THEN
         M = NROWA
      ELSE
         M = NCOLA
      END IF
C
      IF(      .NOT.( UPPER  .OR. LSAME( UPLO,  'L' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( K.LT.0 ) THEN
         INFO = -4
      ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M-1 ) ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01YD', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF( ( N.EQ.0 ).OR.
     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
      IF ( ALPHA.EQ.ZERO ) THEN
         IF ( BETA.EQ.ZERO ) THEN
C
C           Special case when both alpha = 0 and beta = 0.
C
            CALL DLASET( UPLO, N, N, ZERO, ZERO, C, LDC )
         ELSE
C
C           Special case alpha = 0.
C
            CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, C, LDC, INFO )
         END IF
         RETURN
      END IF
C
C     General case: alpha <> 0.
C
      IF ( .NOT.TRANSP ) THEN
C
C        Form  C := alpha*A*A' + beta*C.
C
         IF ( UPPER ) THEN
C
            DO 30 J = 1, N
               IF ( BETA.EQ.ZERO ) THEN
C
                  DO 10 I = 1, J
                     C( I, J ) = ZERO
   10             CONTINUE
C
               ELSE IF ( BETA.NE.ONE ) THEN
                  CALL DSCAL ( J, BETA, C( 1, J ), 1 )
               END IF
C
               DO 20 M = MAX( 1, J-L ), K
                  CALL DAXPY ( MIN( J, L+M ), ALPHA*A( J, M ),
     $                         A( 1, M ), 1, C( 1, J ), 1 )
   20          CONTINUE
C
   30       CONTINUE
C
         ELSE
C
            DO 60 J = 1, N
               IF ( BETA.EQ.ZERO ) THEN
C
                  DO 40 I = J, N
                     C( I, J ) = ZERO
   40             CONTINUE
C
               ELSE IF ( BETA.NE.ONE ) THEN
                  CALL DSCAL ( N-J+1, BETA, C( J, J ), 1 )
               END IF
C
               DO 50 M = 1, MIN( J+L, K )
                  CALL DAXPY ( N-J+1, ALPHA*A( J, M ), A( J, M ), 1,
     $                         C( J, J ), 1 )
   50          CONTINUE
C
   60       CONTINUE
C
         END IF
C
      ELSE
C
C        Form  C := alpha*A'*A + beta*C.
C
         IF ( UPPER ) THEN
C
            DO 80 J = 1, N
C
               DO 70 I = 1, J
                  TEMP = ALPHA*DDOT ( MIN( J+L, K ), A( 1, I ), 1,
     $                                A( 1, J ), 1 )
                  IF ( BETA.EQ.ZERO ) THEN
                     C( I, J ) = TEMP
                  ELSE
                     C( I, J ) = TEMP + BETA*C( I, J )
                  END IF
   70          CONTINUE
C
   80       CONTINUE
C
         ELSE
C
            DO 100 J = 1, N
C
               DO 90 I = J, N
                  M = MAX( 1, I-L )
                  TEMP = ALPHA*DDOT ( K-M+1, A( M, I ), 1, A( M, J ),
     $                                1 )
                  IF ( BETA.EQ.ZERO ) THEN
                     C( I, J ) = TEMP
                  ELSE
                     C( I, J ) = TEMP + BETA*C( I, J )
                  END IF
   90          CONTINUE
C
  100       CONTINUE
C
         END IF
C
      END IF
C
      RETURN
C
C *** Last line of MB01YD ***
      END
