smake()

subroutine smake	(	character*2	type,
		character*1	uplo,
		character*1	diag,
		integer	m,
		integer	n,
		real, dimension( nmax, * )	a,
		integer	nmax,
		real, dimension( * )	aa,
		integer	lda,
		integer	kl,
		integer	ku,
		logical	reset,
		real	transl
	)

Definition at line 2463 of file c_sblat2.f.

*
*  Generates values for an M by N matrix A within the bandwidth
*  defined by KL and KU.
*  Stores the values in the array AA in the data structure required
*  by the routine, with unwanted elements set to rogue value.
*
*  TYPE is 'ge', 'gb', 'sy', 'sb', 'sp', 'tr', 'tb' OR 'tp'.
*
*  Auxiliary routine for test program for Level 2 Blas.
*
*  -- Written on 10-August-1987.
*     Richard Hanson, Sandia National Labs.
*     Jeremy Du Croz, NAG Central Office.
*
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter( zero = 0.0, one = 1.0 )
      REAL               ROGUE
      parameter( rogue = -1.0e10 )
*     .. Scalar Arguments ..
      REAL               TRANSL
      INTEGER            KL, KU, LDA, M, N, NMAX
      LOGICAL            RESET
      CHARACTER*1        DIAG, UPLO
      CHARACTER*2        TYPE
*     .. Array Arguments ..
      REAL               A( NMAX, * ), AA( * )
*     .. Local Scalars ..
      INTEGER            I, I1, I2, I3, IBEG, IEND, IOFF, J, KK
      LOGICAL            GEN, LOWER, SYM, TRI, UNIT, UPPER
*     .. External Functions ..
      REAL               SBEG
      EXTERNAL           sbeg
*     .. Intrinsic Functions ..
      INTRINSIC          max, min
*     .. Executable Statements ..
      gen = TYPE( 1: 1 ).EQ.'g'
      sym = TYPE( 1: 1 ).EQ.'s'
      tri = TYPE( 1: 1 ).EQ.'t'
      upper = ( sym.OR.tri ).AND.uplo.EQ.'U'
      lower = ( sym.OR.tri ).AND.uplo.EQ.'L'
      unit = tri.AND.diag.EQ.'U'
*
*     Generate data in array A.
*
      DO 20 j = 1, n
         DO 10 i = 1, m
            IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
     $          THEN
               IF( ( i.LE.j.AND.j - i.LE.ku ).OR.
     $             ( i.GE.j.AND.i - j.LE.kl ) )THEN
                  a( i, j ) = sbeg( reset ) + transl
               ELSE
                  a( i, j ) = zero
               END IF
               IF( i.NE.j )THEN
                  IF( sym )THEN
                     a( j, i ) = a( i, j )
                  ELSE IF( tri )THEN
                     a( j, i ) = zero
                  END IF
               END IF
            END IF
   10    CONTINUE
         IF( tri )
     $      a( j, j ) = a( j, j ) + one
         IF( unit )
     $      a( j, j ) = one
   20 CONTINUE
*
*     Store elements in array AS in data structure required by routine.
*
      IF( type.EQ.'ge' )THEN
         DO 50 j = 1, n
            DO 30 i = 1, m
               aa( i + ( j - 1 )*lda ) = a( i, j )
   30       CONTINUE
            DO 40 i = m + 1, lda
               aa( i + ( j - 1 )*lda ) = rogue
   40       CONTINUE
   50    CONTINUE
      ELSE IF( type.EQ.'gb' )THEN
         DO 90 j = 1, n
            DO 60 i1 = 1, ku + 1 - j
               aa( i1 + ( j - 1 )*lda ) = rogue
   60       CONTINUE
            DO 70 i2 = i1, min( kl + ku + 1, ku + 1 + m - j )
               aa( i2 + ( j - 1 )*lda ) = a( i2 + j - ku - 1, j )
   70       CONTINUE
            DO 80 i3 = i2, lda
               aa( i3 + ( j - 1 )*lda ) = rogue
   80       CONTINUE
   90    CONTINUE
      ELSE IF( type.EQ.'sy'.OR.type.EQ.'tr' )THEN
         DO 130 j = 1, n
            IF( upper )THEN
               ibeg = 1
               IF( unit )THEN
                  iend = j - 1
               ELSE
                  iend = j
               END IF
            ELSE
               IF( unit )THEN
                  ibeg = j + 1
               ELSE
                  ibeg = j
               END IF
               iend = n
            END IF
            DO 100 i = 1, ibeg - 1
               aa( i + ( j - 1 )*lda ) = rogue
  100       CONTINUE
            DO 110 i = ibeg, iend
               aa( i + ( j - 1 )*lda ) = a( i, j )
  110       CONTINUE
            DO 120 i = iend + 1, lda
               aa( i + ( j - 1 )*lda ) = rogue
  120       CONTINUE
  130    CONTINUE
      ELSE IF( type.EQ.'sb'.OR.type.EQ.'tb' )THEN
         DO 170 j = 1, n
            IF( upper )THEN
               kk = kl + 1
               ibeg = max( 1, kl + 2 - j )
               IF( unit )THEN
                  iend = kl
               ELSE
                  iend = kl + 1
               END IF
            ELSE
               kk = 1
               IF( unit )THEN
                  ibeg = 2
               ELSE
                  ibeg = 1
               END IF
               iend = min( kl + 1, 1 + m - j )
            END IF
            DO 140 i = 1, ibeg - 1
               aa( i + ( j - 1 )*lda ) = rogue
  140       CONTINUE
            DO 150 i = ibeg, iend
               aa( i + ( j - 1 )*lda ) = a( i + j - kk, j )
  150       CONTINUE
            DO 160 i = iend + 1, lda
               aa( i + ( j - 1 )*lda ) = rogue
  160       CONTINUE
  170    CONTINUE
      ELSE IF( type.EQ.'sp'.OR.type.EQ.'tp' )THEN
         ioff = 0
         DO 190 j = 1, n
            IF( upper )THEN
               ibeg = 1
               iend = j
            ELSE
               ibeg = j
               iend = n
            END IF
            DO 180 i = ibeg, iend
               ioff = ioff + 1
               aa( ioff ) = a( i, j )
               IF( i.EQ.j )THEN
                  IF( unit )
     $               aa( ioff ) = rogue
               END IF
  180       CONTINUE
  190    CONTINUE
      END IF
      RETURN
*
*     End of SMAKE.
*