zlatmr.f

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

         INFO = -21
      ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN
         INFO = -22
      ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR.
     $         IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR.
     $         ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE.
     $         N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE.
     $         0 .OR. M.NE.N ) ) ) THEN
         INFO = -24
      ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND.
     $         LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ.
     $         4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ.
     $         6 ) .AND. LDA.LT.KUU+1 ) .OR.
     $         ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN
         INFO = -26
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZLATMR', -INFO )
         RETURN
      END IF
*
*     Decide if we can pivot consistently
*
      FULBND = .FALSE.
      IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 )
     $   FULBND = .TRUE.
*
*     Initialize random number generator
*
      DO 30 I = 1, 4
         ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
   30 CONTINUE
*
      ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1
*
*     2)      Set up D, DL, and DR, if indicated.
*
*             Compute D according to COND and MODE
*
      CALL ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = 1
         RETURN
      END IF
      IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN
*
*        Scale by DMAX
*
         TEMP = ABS( D( 1 ) )
         DO 40 I = 2, MNMIN
            TEMP = MAX( TEMP, ABS( D( I ) ) )
   40    CONTINUE
         IF( TEMP.EQ.ZERO .AND. DMAX.NE.CZERO ) THEN
            INFO = 2
            RETURN
         END IF
         IF( TEMP.NE.ZERO ) THEN
            CALPHA = DMAX / TEMP
         ELSE
            CALPHA = CONE
         END IF
         DO 50 I = 1, MNMIN
            D( I ) = CALPHA*D( I )
   50    CONTINUE
*
      END IF
*
*     If matrix Hermitian, make D real
*
      IF( ISYM.EQ.0 ) THEN
         DO 60 I = 1, MNMIN
            D( I ) = DBLE( D( I ) )
   60    CONTINUE
      END IF
*
*     Compute DL if grading set
*
      IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ.
     $    5 .OR. IGRADE.EQ.6 ) THEN
         CALL ZLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO )
         IF( INFO.NE.0 ) THEN
            INFO = 3
            RETURN
         END IF
      END IF
*
*     Compute DR if grading set
*
      IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN
         CALL ZLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO )
         IF( INFO.NE.0 ) THEN
            INFO = 4
            RETURN
         END IF
      END IF
*
*     3)     Generate IWORK if pivoting
*
      IF( IPVTNG.GT.0 ) THEN
         DO 70 I = 1, NPVTS
            IWORK( I ) = I
   70    CONTINUE
         IF( FULBND ) THEN
            DO 80 I = 1, NPVTS
               K = IPIVOT( I )
               J = IWORK( I )
               IWORK( I ) = IWORK( K )
               IWORK( K ) = J
   80       CONTINUE
         ELSE
            DO 90 I = NPVTS, 1, -1
               K = IPIVOT( I )
               J = IWORK( I )
               IWORK( I ) = IWORK( K )
               IWORK( K ) = J
   90       CONTINUE
         END IF
      END IF
*
*     4)      Generate matrices for each kind of PACKing
*             Always sweep matrix columnwise (if symmetric, upper
*             half only) so that matrix generated does not depend
*             on PACK
*
      IF( FULBND ) THEN
*
*        Use ZLATM3 so matrices generated with differing PIVOTing only
*        differ only in the order of their rows and/or columns.
*
         IF( IPACK.EQ.0 ) THEN
            IF( ISYM.EQ.0 ) THEN
               DO 110 J = 1, N
                  DO 100 I = 1, J
                     CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
     $                       IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                       IWORK, SPARSE )
                     A( ISUB, JSUB ) = CTEMP
                     A( JSUB, ISUB ) = DCONJG( CTEMP )
  100             CONTINUE
  110          CONTINUE
            ELSE IF( ISYM.EQ.1 ) THEN
               DO 130 J = 1, N
                  DO 120 I = 1, M
                     CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
     $                       IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                       IWORK, SPARSE )
                     A( ISUB, JSUB ) = CTEMP
  120             CONTINUE
  130          CONTINUE
            ELSE IF( ISYM.EQ.2 ) THEN
               DO 150 J = 1, N
                  DO 140 I = 1, J
                     CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
     $                       IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                       IWORK, SPARSE )
                     A( ISUB, JSUB ) = CTEMP
                     A( JSUB, ISUB ) = CTEMP
  140             CONTINUE
  150          CONTINUE
            END IF
*
         ELSE IF( IPACK.EQ.1 ) THEN
*
            DO 170 J = 1, N
               DO 160 I = 1, J
                  CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                    ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                    SPARSE )
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN
                     A( MNSUB, MXSUB ) = DCONJG( CTEMP )
                  ELSE
                     A( MNSUB, MXSUB ) = CTEMP
                  END IF
                  IF( MNSUB.NE.MXSUB )
     $               A( MXSUB, MNSUB ) = CZERO
  160          CONTINUE
  170       CONTINUE
*
         ELSE IF( IPACK.EQ.2 ) THEN
*
            DO 190 J = 1, N
               DO 180 I = 1, J
                  CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                    ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                    SPARSE )
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN
                     A( MXSUB, MNSUB ) = DCONJG( CTEMP )
                  ELSE
                     A( MXSUB, MNSUB ) = CTEMP
                  END IF
                  IF( MNSUB.NE.MXSUB )
     $               A( MNSUB, MXSUB ) = CZERO
  180          CONTINUE
  190       CONTINUE
*
         ELSE IF( IPACK.EQ.3 ) THEN
*
            DO 210 J = 1, N
               DO 200 I = 1, J
                  CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                    ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                    SPARSE )
*
*                 Compute K = location of (ISUB,JSUB) entry in packed
*                 array
*
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  K = MXSUB*( MXSUB-1 ) / 2 + MNSUB
*
*                 Convert K to (IISUB,JJSUB) location
*
                  JJSUB = ( K-1 ) / LDA + 1
                  IISUB = K - LDA*( JJSUB-1 )
*
                  IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN
                     A( IISUB, JJSUB ) = DCONJG( CTEMP )
                  ELSE
                     A( IISUB, JJSUB ) = CTEMP
                  END IF
  200          CONTINUE
  210       CONTINUE
*
         ELSE IF( IPACK.EQ.4 ) THEN
*
            DO 230 J = 1, N
               DO 220 I = 1, J
                  CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                    ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                    SPARSE )
*
*                 Compute K = location of (I,J) entry in packed array
*
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  IF( MNSUB.EQ.1 ) THEN
                     K = MXSUB
                  ELSE
                     K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) /
     $                   2 + MXSUB - MNSUB + 1
                  END IF
*
*                 Convert K to (IISUB,JJSUB) location
*
                  JJSUB = ( K-1 ) / LDA + 1
                  IISUB = K - LDA*( JJSUB-1 )
*
                  IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN
                     A( IISUB, JJSUB ) = DCONJG( CTEMP )
                  ELSE
                     A( IISUB, JJSUB ) = CTEMP
                  END IF
  220          CONTINUE
  230       CONTINUE
*
         ELSE IF( IPACK.EQ.5 ) THEN
*
            DO 250 J = 1, N
               DO 240 I = J - KUU, J
                  IF( I.LT.1 ) THEN
                     A( J-I+1, I+N ) = CZERO
                  ELSE
                     CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
     $                       IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                       IWORK, SPARSE )
                     MNSUB = MIN( ISUB, JSUB )
                     MXSUB = MAX( ISUB, JSUB )
                     IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN
                        A( MXSUB-MNSUB+1, MNSUB ) = DCONJG( CTEMP )
                     ELSE
                        A( MXSUB-MNSUB+1, MNSUB ) = CTEMP
                     END IF
                  END IF
  240          CONTINUE
  250       CONTINUE
*
         ELSE IF( IPACK.EQ.6 ) THEN
*
            DO 270 J = 1, N
               DO 260 I = J - KUU, J
                  CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                    ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                    SPARSE )
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN
                     A( MNSUB-MXSUB+KUU+1, MXSUB ) = DCONJG( CTEMP )
                  ELSE
                     A( MNSUB-MXSUB+KUU+1, MXSUB ) = CTEMP
                  END IF
  260          CONTINUE
  270       CONTINUE
*
         ELSE IF( IPACK.EQ.7 ) THEN
*
            IF( ISYM.NE.1 ) THEN
               DO 290 J = 1, N
                  DO 280 I = J - KUU, J
                     CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU,