zlatmr.f

来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,215 行 · 第 1/4 页

*                      option to store A in the trailing rows of
*                      the allocated storage)
*
*           Using these options, the various LAPACK packed and banded
*           storage schemes can be obtained:
*           GB               - use 'Z'
*           PB, HB or TB     - use 'B' or 'Q'
*           PP, HP or TP     - use 'C' or 'R'
*
*           If two calls to ZLATMR differ only in the PACK parameter,
*           they will generate mathematically equivalent matrices.
*           Not modified.
*
*  A      - COMPLEX*16 array, dimension (LDA,N)
*           On exit A is the desired test matrix. Only those
*           entries of A which are significant on output
*           will be referenced (even if A is in packed or band
*           storage format). The 'unoccupied corners' of A in
*           band format will be zeroed out.
*
*  LDA    - INTEGER
*           on entry LDA specifies the first dimension of A as
*           declared in the calling program.
*           If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ).
*           If PACK='C' or 'R', LDA must be at least 1.
*           If PACK='B', or 'Q', LDA must be MIN ( KU+1, N )
*           If PACK='Z', LDA must be at least KUU+KLL+1, where
*           KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 )
*           Not modified.
*
*  IWORK  - INTEGER array, dimension (N or M)
*           Workspace. Not referenced if PIVTNG = 'N'. Changed on exit.
*
*  INFO   - INTEGER
*           Error parameter on exit:
*             0 => normal return
*            -1 => M negative or unequal to N and SYM='S' or 'H'
*            -2 => N negative
*            -3 => DIST illegal string
*            -5 => SYM illegal string
*            -7 => MODE not in range -6 to 6
*            -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
*           -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string
*           -11 => GRADE illegal string, or GRADE='E' and
*                  M not equal to N, or GRADE='L', 'R', 'B', 'S' or 'E'
*                  and SYM = 'H', or GRADE='L', 'R', 'B', 'H' or 'E'
*                  and SYM = 'S'
*           -12 => GRADE = 'E' and DL contains zero
*           -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H',
*                  'S' or 'E'
*           -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E',
*                  and MODEL neither -6, 0 nor 6
*           -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B'
*           -17 => CONDR less than 1.0, GRADE='R' or 'B', and
*                  MODER neither -6, 0 nor 6
*           -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and
*                  M not equal to N, or PIVTNG='L' or 'R' and SYM='S'
*                  or 'H'
*           -19 => IPIVOT contains out of range number and
*                  PIVTNG not equal to 'N'
*           -20 => KL negative
*           -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL
*           -22 => SPARSE not in range 0. to 1.
*           -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q'
*                  and SYM='N', or PACK='C' and SYM='N' and either KL
*                  not equal to 0 or N not equal to M, or PACK='R' and
*                  SYM='N', and either KU not equal to 0 or N not equal
*                  to M
*           -26 => LDA too small
*             1 => Error return from ZLATM1 (computing D)
*             2 => Cannot scale diagonal to DMAX (max. entry is 0)
*             3 => Error return from ZLATM1 (computing DL)
*             4 => Error return from ZLATM1 (computing DR)
*             5 => ANORM is positive, but matrix constructed prior to
*                  attempting to scale it to have norm ANORM, is zero
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      COMPLEX*16         CONE
      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )
      COMPLEX*16         CZERO
      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            BADPVT, DZERO, FULBND
      INTEGER            I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN,
     $                   ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN,
     $                   MNSUB, MXSUB, NPVTS
      DOUBLE PRECISION   ONORM, TEMP
      COMPLEX*16         CALPHA, CTEMP
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   TEMPA( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   ZLANGB, ZLANGE, ZLANSB, ZLANSP, ZLANSY
      COMPLEX*16         ZLATM2, ZLATM3
      EXTERNAL           LSAME, ZLANGB, ZLANGE, ZLANSB, ZLANSP, ZLANSY,
     $                   ZLATM2, ZLATM3
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZDSCAL, ZLATM1
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, MAX, MIN, MOD
*     ..
*     .. Executable Statements ..
*
*     1)      Decode and Test the input parameters.
*             Initialize flags & seed.
*
      INFO = 0
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Decode DIST
*
      IF( LSAME( DIST, 'U' ) ) THEN
         IDIST = 1
      ELSE IF( LSAME( DIST, 'S' ) ) THEN
         IDIST = 2
      ELSE IF( LSAME( DIST, 'N' ) ) THEN
         IDIST = 3
      ELSE IF( LSAME( DIST, 'D' ) ) THEN
         IDIST = 4
      ELSE
         IDIST = -1
      END IF
*
*     Decode SYM
*
      IF( LSAME( SYM, 'H' ) ) THEN
         ISYM = 0
      ELSE IF( LSAME( SYM, 'N' ) ) THEN
         ISYM = 1
      ELSE IF( LSAME( SYM, 'S' ) ) THEN
         ISYM = 2
      ELSE
         ISYM = -1
      END IF
*
*     Decode RSIGN
*
      IF( LSAME( RSIGN, 'F' ) ) THEN
         IRSIGN = 0
      ELSE IF( LSAME( RSIGN, 'T' ) ) THEN
         IRSIGN = 1
      ELSE
         IRSIGN = -1
      END IF
*
*     Decode PIVTNG
*
      IF( LSAME( PIVTNG, 'N' ) ) THEN
         IPVTNG = 0
      ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN
         IPVTNG = 0
      ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN
         IPVTNG = 1
         NPVTS = M
      ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN
         IPVTNG = 2
         NPVTS = N
      ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN
         IPVTNG = 3
         NPVTS = MIN( N, M )
      ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN
         IPVTNG = 3
         NPVTS = MIN( N, M )
      ELSE
         IPVTNG = -1
      END IF
*
*     Decode GRADE
*
      IF( LSAME( GRADE, 'N' ) ) THEN
         IGRADE = 0
      ELSE IF( LSAME( GRADE, 'L' ) ) THEN
         IGRADE = 1
      ELSE IF( LSAME( GRADE, 'R' ) ) THEN
         IGRADE = 2
      ELSE IF( LSAME( GRADE, 'B' ) ) THEN
         IGRADE = 3
      ELSE IF( LSAME( GRADE, 'E' ) ) THEN
         IGRADE = 4
      ELSE IF( LSAME( GRADE, 'H' ) ) THEN
         IGRADE = 5
      ELSE IF( LSAME( GRADE, 'S' ) ) THEN
         IGRADE = 6
      ELSE
         IGRADE = -1
      END IF
*
*     Decode PACK
*
      IF( LSAME( PACK, 'N' ) ) THEN
         IPACK = 0
      ELSE IF( LSAME( PACK, 'U' ) ) THEN
         IPACK = 1
      ELSE IF( LSAME( PACK, 'L' ) ) THEN
         IPACK = 2
      ELSE IF( LSAME( PACK, 'C' ) ) THEN
         IPACK = 3
      ELSE IF( LSAME( PACK, 'R' ) ) THEN
         IPACK = 4
      ELSE IF( LSAME( PACK, 'B' ) ) THEN
         IPACK = 5
      ELSE IF( LSAME( PACK, 'Q' ) ) THEN
         IPACK = 6
      ELSE IF( LSAME( PACK, 'Z' ) ) THEN
         IPACK = 7
      ELSE
         IPACK = -1
      END IF
*
*     Set certain internal parameters
*
      MNMIN = MIN( M, N )
      KLL = MIN( KL, M-1 )
      KUU = MIN( KU, N-1 )
*
*     If inv(DL) is used, check to see if DL has a zero entry.
*
      DZERO = .FALSE.
      IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN
         DO 10 I = 1, M
            IF( DL( I ).EQ.CZERO )
     $         DZERO = .TRUE.
   10    CONTINUE
      END IF
*
*     Check values in IPIVOT
*
      BADPVT = .FALSE.
      IF( IPVTNG.GT.0 ) THEN
         DO 20 J = 1, NPVTS
            IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS )
     $         BADPVT = .TRUE.
   20    CONTINUE
      END IF
*
*     Set INFO if an error
*
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.NE.N .AND. ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( IDIST.EQ.-1 ) THEN
         INFO = -3
      ELSE IF( ISYM.EQ.-1 ) THEN
         INFO = -5
      ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
         INFO = -7
      ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $         COND.LT.ONE ) THEN
         INFO = -8
      ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $         IRSIGN.EQ.-1 ) THEN
         INFO = -10
      ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR.
     $         ( ( IGRADE.EQ.1 .OR. IGRADE.EQ.2 .OR. IGRADE.EQ.3 .OR.
     $         IGRADE.EQ.4 .OR. IGRADE.EQ.6 ) .AND. ISYM.EQ.0 ) .OR.
     $         ( ( IGRADE.EQ.1 .OR. IGRADE.EQ.2 .OR. IGRADE.EQ.3 .OR.
     $         IGRADE.EQ.4 .OR. IGRADE.EQ.5 ) .AND. ISYM.EQ.2 ) ) THEN
         INFO = -11
      ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN
         INFO = -12
      ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
     $         IGRADE.EQ.5 .OR. IGRADE.EQ.6 ) .AND.
     $         ( MODEL.LT.-6 .OR. MODEL.GT.6 ) ) THEN
         INFO = -13
      ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
     $         IGRADE.EQ.5 .OR. IGRADE.EQ.6 ) .AND.
     $         ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND. MODEL.NE.6 ) .AND.
     $         CONDL.LT.ONE ) THEN
         INFO = -14
      ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
     $         ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN
         INFO = -16
      ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
     $         ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND.
     $         CONDR.LT.ONE ) THEN
         INFO = -17
      ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR.
     $         ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ( ISYM.EQ.0 .OR.
     $         ISYM.EQ.2 ) ) ) THEN
         INFO = -18
      ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN
         INFO = -19
      ELSE IF( KL.LT.0 ) THEN
         INFO = -20
      ELSE IF( KU.LT.0 .OR. ( ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) .AND. KL.NE.
     $         KU ) ) THEN