OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dggbal.f
Go to the documentation of this file.
1*> \brief \b DGGBAL
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download DGGBAL + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dggbal.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dggbal.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dggbal.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18* Definition:
19* ===========
20*
21* SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
22* RSCALE, WORK, INFO )
23*
24* .. Scalar Arguments ..
25* CHARACTER JOB
26* INTEGER IHI, ILO, INFO, LDA, LDB, N
27* ..
28* .. Array Arguments ..
29* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ),
30* $ RSCALE( * ), WORK( * )
31* ..
32*
33*
34*> \par Purpose:
35* =============
36*>
37*> \verbatim
38*>
39*> DGGBAL balances a pair of general real matrices (A,B). This
40*> involves, first, permuting A and B by similarity transformations to
41*> isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
42*> elements on the diagonal; and second, applying a diagonal similarity
43*> transformation to rows and columns ILO to IHI to make the rows
44*> and columns as close in norm as possible. Both steps are optional.
45*>
46*> Balancing may reduce the 1-norm of the matrices, and improve the
47*> accuracy of the computed eigenvalues and/or eigenvectors in the
48*> generalized eigenvalue problem A*x = lambda*B*x.
49*> \endverbatim
50*
51* Arguments:
52* ==========
53*
54*> \param[in] JOB
55*> \verbatim
56*> JOB is CHARACTER*1
57*> Specifies the operations to be performed on A and B:
58*> = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
59*> and RSCALE(I) = 1.0 for i = 1,...,N.
60*> = 'P': permute only;
61*> = 'S': scale only;
62*> = 'B': both permute and scale.
63*> \endverbatim
64*>
65*> \param[in] N
66*> \verbatim
67*> N is INTEGER
68*> The order of the matrices A and B. N >= 0.
69*> \endverbatim
70*>
71*> \param[in,out] A
72*> \verbatim
73*> A is DOUBLE PRECISION array, dimension (LDA,N)
74*> On entry, the input matrix A.
75*> On exit, A is overwritten by the balanced matrix.
76*> If JOB = 'N', A is not referenced.
77*> \endverbatim
78*>
79*> \param[in] LDA
80*> \verbatim
81*> LDA is INTEGER
82*> The leading dimension of the array A. LDA >= max(1,N).
83*> \endverbatim
84*>
85*> \param[in,out] B
86*> \verbatim
87*> B is DOUBLE PRECISION array, dimension (LDB,N)
88*> On entry, the input matrix B.
89*> On exit, B is overwritten by the balanced matrix.
90*> If JOB = 'N', B is not referenced.
91*> \endverbatim
92*>
93*> \param[in] LDB
94*> \verbatim
95*> LDB is INTEGER
96*> The leading dimension of the array B. LDB >= max(1,N).
97*> \endverbatim
98*>
99*> \param[out] ILO
100*> \verbatim
101*> ILO is INTEGER
102*> \endverbatim
103*>
104*> \param[out] IHI
105*> \verbatim
106*> IHI is INTEGER
107*> ILO and IHI are set to integers such that on exit
108*> A(i,j) = 0 and B(i,j) = 0 if i > j and
109*> j = 1,...,ILO-1 or i = IHI+1,...,N.
110*> If JOB = 'N' or 'S', ILO = 1 and IHI = N.
111*> \endverbatim
112*>
113*> \param[out] LSCALE
114*> \verbatim
115*> LSCALE is DOUBLE PRECISION array, dimension (N)
116*> Details of the permutations and scaling factors applied
117*> to the left side of A and B. If P(j) is the index of the
118*> row interchanged with row j, and D(j)
119*> is the scaling factor applied to row j, then
120*> LSCALE(j) = P(j) for J = 1,...,ILO-1
121*> = D(j) for J = ILO,...,IHI
122*> = P(j) for J = IHI+1,...,N.
123*> The order in which the interchanges are made is N to IHI+1,
124*> then 1 to ILO-1.
125*> \endverbatim
126*>
127*> \param[out] RSCALE
128*> \verbatim
129*> RSCALE is DOUBLE PRECISION array, dimension (N)
130*> Details of the permutations and scaling factors applied
131*> to the right side of A and B. If P(j) is the index of the
132*> column interchanged with column j, and D(j)
133*> is the scaling factor applied to column j, then
134*> LSCALE(j) = P(j) for J = 1,...,ILO-1
135*> = D(j) for J = ILO,...,IHI
136*> = P(j) for J = IHI+1,...,N.
137*> The order in which the interchanges are made is N to IHI+1,
138*> then 1 to ILO-1.
139*> \endverbatim
140*>
141*> \param[out] WORK
142*> \verbatim
143*> WORK is DOUBLE PRECISION array, dimension (lwork)
144*> lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
145*> at least 1 when JOB = 'N' or 'P'.
146*> \endverbatim
147*>
148*> \param[out] INFO
149*> \verbatim
150*> INFO is INTEGER
151*> = 0: successful exit
152*> < 0: if INFO = -i, the i-th argument had an illegal value.
153*> \endverbatim
154*
155* Authors:
156* ========
157*
158*> \author Univ. of Tennessee
159*> \author Univ. of California Berkeley
160*> \author Univ. of Colorado Denver
161*> \author NAG Ltd.
162*
163*> \ingroup doubleGBcomputational
164*
165*> \par Further Details:
166* =====================
167*>
168*> \verbatim
169*>
170*> See R.C. WARD, Balancing the generalized eigenvalue problem,
171*> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
172*> \endverbatim
173*>
174* =====================================================================
175 SUBROUTINE dggbal( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
176 $ RSCALE, WORK, INFO )
177*
178* -- LAPACK computational routine --
179* -- LAPACK is a software package provided by Univ. of Tennessee, --
180* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
181*
182* .. Scalar Arguments ..
183 CHARACTER JOB
184 INTEGER IHI, ILO, INFO, LDA, LDB, N
185* ..
186* .. Array Arguments ..
187 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ),
188 $ rscale( * ), work( * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 DOUBLE PRECISION ZERO, HALF, ONE
195 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0 )
196 DOUBLE PRECISION THREE, SCLFAC
197 parameter( three = 3.0d+0, sclfac = 1.0d+1 )
198* ..
199* .. Local Scalars ..
200 INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
201 $ k, kount, l, lcab, lm1, lrab, lsfmax, lsfmin,
202 $ m, nr, nrp2
203 DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
204 $ coef5, cor, ew, ewc, gamma, pgamma, rab, sfmax,
205 $ sfmin, sum, t, ta, tb, tc
206* ..
207* .. External Functions ..
208 LOGICAL LSAME
209 INTEGER IDAMAX
210 DOUBLE PRECISION DDOT, DLAMCH
211 EXTERNAL lsame, idamax, ddot, dlamch
212* ..
213* .. External Subroutines ..
214 EXTERNAL daxpy, dscal, dswap, xerbla
215* ..
216* .. Intrinsic Functions ..
217 INTRINSIC abs, dble, int, log10, max, min, sign
218* ..
219* .. Executable Statements ..
220*
221* Test the input parameters
222*
223 info = 0
224 IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND.
225 $ .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN
226 info = -1
227 ELSE IF( n.LT.0 ) THEN
228 info = -2
229 ELSE IF( lda.LT.max( 1, n ) ) THEN
230 info = -4
231 ELSE IF( ldb.LT.max( 1, n ) ) THEN
232 info = -6
233 END IF
234 IF( info.NE.0 ) THEN
235 CALL xerbla( 'DGGBAL', -info )
236 RETURN
237 END IF
238*
239* Quick return if possible
240*
241 IF( n.EQ.0 ) THEN
242 ilo = 1
243 ihi = n
244 RETURN
245 END IF
246*
247 IF( n.EQ.1 ) THEN
248 ilo = 1
249 ihi = n
250 lscale( 1 ) = one
251 rscale( 1 ) = one
252 RETURN
253 END IF
254*
255 IF( lsame( job, 'N' ) ) THEN
256 ilo = 1
257 ihi = n
258 DO 10 i = 1, n
259 lscale( i ) = one
260 rscale( i ) = one
261 10 CONTINUE
262 RETURN
263 END IF
264*
265 k = 1
266 l = n
267 IF( lsame( job, 'S' ) )
268 $ GO TO 190
269*
270 GO TO 30
271*
272* Permute the matrices A and B to isolate the eigenvalues.
273*
274* Find row with one nonzero in columns 1 through L
275*
276 20 CONTINUE
277 l = lm1
278 IF( l.NE.1 )
279 $ GO TO 30
280*
281 rscale( 1 ) = one
282 lscale( 1 ) = one
283 GO TO 190
284*
285 30 CONTINUE
286 lm1 = l - 1
287 DO 80 i = l, 1, -1
288 DO 40 j = 1, lm1
289 jp1 = j + 1
290 IF( a( i, j ).NE.zero .OR. b( i, j ).NE.zero )
291 $ GO TO 50
292 40 CONTINUE
293 j = l
294 GO TO 70
295*
296 50 CONTINUE
297 DO 60 j = jp1, l
298 IF( a( i, j ).NE.zero .OR. b( i, j ).NE.zero )
299 $ GO TO 80
300 60 CONTINUE
301 j = jp1 - 1
302*
303 70 CONTINUE
304 m = l
305 iflow = 1
306 GO TO 160
307 80 CONTINUE
308 GO TO 100
309*
310* Find column with one nonzero in rows K through N
311*
312 90 CONTINUE
313 k = k + 1
314*
315 100 CONTINUE
316 DO 150 j = k, l
317 DO 110 i = k, lm1
318 ip1 = i + 1
319 IF( a( i, j ).NE.zero .OR. b( i, j ).NE.zero )
320 $ GO TO 120
321 110 CONTINUE
322 i = l
323 GO TO 140
324 120 CONTINUE
325 DO 130 i = ip1, l
326 IF( a( i, j ).NE.zero .OR. b( i, j ).NE.zero )
327 $ GO TO 150
328 130 CONTINUE
329 i = ip1 - 1
330 140 CONTINUE
331 m = k
332 iflow = 2
333 GO TO 160
334 150 CONTINUE
335 GO TO 190
336*
337* Permute rows M and I
338*
339 160 CONTINUE
340 lscale( m ) = i
341 IF( i.EQ.m )
342 $ GO TO 170
343 CALL dswap( n-k+1, a( i, k ), lda, a( m, k ), lda )
344 CALL dswap( n-k+1, b( i, k ), ldb, b( m, k ), ldb )
345*
346* Permute columns M and J
347*
348 170 CONTINUE
349 rscale( m ) = j
350 IF( j.EQ.m )
351 $ GO TO 180
352 CALL dswap( l, a( 1, j ), 1, a( 1, m ), 1 )
353 CALL dswap( l, b( 1, j ), 1, b( 1, m ), 1 )
354*
355 180 CONTINUE
356 GO TO ( 20, 90 )iflow
357*
358 190 CONTINUE
359 ilo = k
360 ihi = l
361*
362 IF( lsame( job, 'P' ) ) THEN
363 DO 195 i = ilo, ihi
364 lscale( i ) = one
365 rscale( i ) = one
366 195 CONTINUE
367 RETURN
368 END IF
369*
370 IF( ilo.EQ.ihi )
371 $ RETURN
372*
373* Balance the submatrix in rows ILO to IHI.
374*
375 nr = ihi - ilo + 1
376 DO 200 i = ilo, ihi
377 rscale( i ) = zero
378 lscale( i ) = zero
379*
380 work( i ) = zero
381 work( i+n ) = zero
382 work( i+2*n ) = zero
383 work( i+3*n ) = zero
384 work( i+4*n ) = zero
385 work( i+5*n ) = zero
386 200 CONTINUE
387*
388* Compute right side vector in resulting linear equations
389*
390 basl = log10( sclfac )
391 DO 240 i = ilo, ihi
392 DO 230 j = ilo, ihi
393 tb = b( i, j )
394 ta = a( i, j )
395 IF( ta.EQ.zero )
396 $ GO TO 210
397 ta = log10( abs( ta ) ) / basl
398 210 CONTINUE
399 IF( tb.EQ.zero )
400 $ GO TO 220
401 tb = log10( abs( tb ) ) / basl
402 220 CONTINUE
403 work( i+4*n ) = work( i+4*n ) - ta - tb
404 work( j+5*n ) = work( j+5*n ) - ta - tb
405 230 CONTINUE
406 240 CONTINUE
407*
408 coef = one / dble( 2*nr )
409 coef2 = coef*coef
410 coef5 = half*coef2
411 nrp2 = nr + 2
412 beta = zero
413 it = 1
414*
415* Start generalized conjugate gradient iteration
416*
417 250 CONTINUE
418*
419 gamma = ddot( nr, work( ilo+4*n ), 1, work( ilo+4*n ), 1 ) +
420 $ ddot( nr, work( ilo+5*n ), 1, work( ilo+5*n ), 1 )
421*
422 ew = zero
423 ewc = zero
424 DO 260 i = ilo, ihi
425 ew = ew + work( i+4*n )
426 ewc = ewc + work( i+5*n )
427 260 CONTINUE
428*
429 gamma = coef*gamma - coef2*( ew**2+ewc**2 ) - coef5*( ew-ewc )**2
430 IF( gamma.EQ.zero )
431 $ GO TO 350
432 IF( it.NE.1 )
433 $ beta = gamma / pgamma
434 t = coef5*( ewc-three*ew )
435 tc = coef5*( ew-three*ewc )
436*
437 CALL dscal( nr, beta, work( ilo ), 1 )
438 CALL dscal( nr, beta, work( ilo+n ), 1 )
439*
440 CALL daxpy( nr, coef, work( ilo+4*n ), 1, work( ilo+n ), 1 )
441 CALL daxpy( nr, coef, work( ilo+5*n ), 1, work( ilo ), 1 )
442*
443 DO 270 i = ilo, ihi
444 work( i ) = work( i ) + tc
445 work( i+n ) = work( i+n ) + t
446 270 CONTINUE
447*
448* Apply matrix to vector
449*
450 DO 300 i = ilo, ihi
451 kount = 0
452 sum = zero
453 DO 290 j = ilo, ihi
454 IF( a( i, j ).EQ.zero )
455 $ GO TO 280
456 kount = kount + 1
457 sum = sum + work( j )
458 280 CONTINUE
459 IF( b( i, j ).EQ.zero )
460 $ GO TO 290
461 kount = kount + 1
462 sum = sum + work( j )
463 290 CONTINUE
464 work( i+2*n ) = dble( kount )*work( i+n ) + sum
465 300 CONTINUE
466*
467 DO 330 j = ilo, ihi
468 kount = 0
469 sum = zero
470 DO 320 i = ilo, ihi
471 IF( a( i, j ).EQ.zero )
472 $ GO TO 310
473 kount = kount + 1
474 sum = sum + work( i+n )
475 310 CONTINUE
476 IF( b( i, j ).EQ.zero )
477 $ GO TO 320
478 kount = kount + 1
479 sum = sum + work( i+n )
480 320 CONTINUE
481 work( j+3*n ) = dble( kount )*work( j ) + sum
482 330 CONTINUE
483*
484 sum = ddot( nr, work( ilo+n ), 1, work( ilo+2*n ), 1 ) +
485 $ ddot( nr, work( ilo ), 1, work( ilo+3*n ), 1 )
486 alpha = gamma / sum
487*
488* Determine correction to current iteration
489*
490 cmax = zero
491 DO 340 i = ilo, ihi
492 cor = alpha*work( i+n )
493 IF( abs( cor ).GT.cmax )
494 $ cmax = abs( cor )
495 lscale( i ) = lscale( i ) + cor
496 cor = alpha*work( i )
497 IF( abs( cor ).GT.cmax )
498 $ cmax = abs( cor )
499 rscale( i ) = rscale( i ) + cor
500 340 CONTINUE
501 IF( cmax.LT.half )
502 $ GO TO 350
503*
504 CALL daxpy( nr, -alpha, work( ilo+2*n ), 1, work( ilo+4*n ), 1 )
505 CALL daxpy( nr, -alpha, work( ilo+3*n ), 1, work( ilo+5*n ), 1 )
506*
507 pgamma = gamma
508 it = it + 1
509 IF( it.LE.nrp2 )
510 $ GO TO 250
511*
512* End generalized conjugate gradient iteration
513*
514 350 CONTINUE
515 sfmin = dlamch( 's' )
516 SFMAX = ONE / SFMIN
517 LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
518 LSFMAX = INT( LOG10( SFMAX ) / BASL )
519 DO 360 I = ILO, IHI
520 IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA )
521 RAB = ABS( A( I, IRAB+ILO-1 ) )
522 IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB )
523 RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
524 LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
525 IR = INT(LSCALE( I ) + SIGN( HALF, LSCALE( I ) ))
526 IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
527 LSCALE( I ) = SCLFAC**IR
528 ICAB = IDAMAX( IHI, A( 1, I ), 1 )
529 CAB = ABS( A( ICAB, I ) )
530 ICAB = IDAMAX( IHI, B( 1, I ), 1 )
531 CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
532 LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
533 JC = INT(RSCALE( I ) + SIGN( HALF, RSCALE( I ) ))
534 JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
535 RSCALE( I ) = SCLFAC**JC
536 360 CONTINUE
537*
538* Row scaling of matrices A and B
539*
540 DO 370 I = ILO, IHI
541 CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
542 CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
543 370 CONTINUE
544*
545* Column scaling of matrices A and B
546*
547 DO 380 J = ILO, IHI
548 CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
549 CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
550 380 CONTINUE
551*
552 RETURN
553*
554* End of DGGBAL
555*
556 END
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
dggbal
subroutine dggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, info)
DGGBAL
Definition dggbal.f:177
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
dswap
subroutine dswap(n, dx, incx, dy, incy)
DSWAP
Definition dswap.f:82
daxpy
subroutine daxpy(n, da, dx, incx, dy, incy)
DAXPY
Definition daxpy.f:89
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21