85 SUBROUTINE cget35( RMAX, LMAX, NINFO, KNT, NIN )
93 INTEGER KNT, LMAX, NIN, NINFO
101 parameter ( ldt = 10 )
103 parameter ( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
105 parameter ( large = 1.0e6 )
107 parameter ( cone = 1.0e0 )
110 CHARACTER TRANA, TRANB
111 INTEGER I, IMLA, IMLAD, IMLB, IMLC, INFO, ISGN, ITRANA,
113 REAL BIGNUM, EPS, RES, RES1, SCALE, SMLNUM, TNRM,
118 REAL DUM( 1 ), VM1( 3 ), VM2( 3 )
119 COMPLEX A( ldt, ldt ), ATMP( ldt, ldt ), B( ldt, ldt ),
120 $ btmp( ldt, ldt ), c( ldt, ldt ),
121 $ csav( ldt, ldt ), ctmp( ldt, ldt )
125 EXTERNAL clange, slamch
131 INTRINSIC abs, max,
REAL, SQRT
138 smlnum = slamch(
'S' ) / eps
139 bignum = one / smlnum
140 CALL slabad( smlnum, bignum )
144 vm1( 1 ) = sqrt( smlnum )
148 vm2( 2 ) = one + two*eps
159 READ( nin, fmt = * )m, n
163 READ( nin, fmt = * )( atmp( i, j ), j = 1, m )
166 READ( nin, fmt = * )( btmp( i, j ), j = 1, n )
169 READ( nin, fmt = * )( ctmp( i, j ), j = 1, n )
177 DO 110 isgn = -1, 1, 2
189 a( i, j ) = atmp( i, j )*vm1( imla )
190 tnrm = max( tnrm, abs( a( i, j ) ) )
192 a( i, i ) = a( i, i )*vm2( imlad )
193 tnrm = max( tnrm, abs( a( i, i ) ) )
197 b( i, j ) = btmp( i, j )*vm1( imlb )
198 tnrm = max( tnrm, abs( b( i, j ) ) )
205 c( i, j ) = ctmp( i, j )*vm1( imlc )
206 csav( i, j ) = c( i, j )
210 CALL ctrsyl( trana, tranb, isgn, m, n, a,
211 $ ldt, b, ldt, c, ldt, scale,
215 xnrm = clange(
'M', m, n, c, ldt, dum )
217 IF( xnrm.GT.one .AND. tnrm.GT.one )
THEN
218 IF( xnrm.GT.bignum / tnrm )
THEN
219 rmul = max( xnrm, tnrm )
223 CALL cgemm( trana,
'N', m, n, m, rmul, a,
224 $ ldt, c, ldt, -scale*rmul, csav,
226 CALL cgemm(
'N', tranb, m, n, n,
227 $
REAL( isgn )*RMUL, C, LDT, B,
228 $ ldt, cone, csav, ldt )
229 res1 = clange(
'M', m, n, csav, ldt, dum )
230 res = res1 / max( smlnum, smlnum*xnrm,
231 $ ( ( abs( rmul )*tnrm )*eps )*xnrm )
232 IF( res.GT.rmax )
THEN
subroutine ctrsyl(TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO)
CTRSYL
subroutine cget35(RMAX, LMAX, NINFO, KNT, NIN)
CGET35
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM