SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
pdlanhs.f
Go to the documentation of this file.
1 DOUBLE PRECISION FUNCTION pdlanhs( NORM, N, A, IA, JA, DESCA,
2 $ WORK )
3*
4* -- ScaLAPACK auxiliary routine (version 1.7) --
5* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6* and University of California, Berkeley.
7* May 1, 1997
8*
9* .. Scalar Arguments ..
10 CHARACTER norm
11 INTEGER ia, ja, n
12* ..
13* .. Array Arguments ..
14 INTEGER desca( * )
15 DOUBLE PRECISION a( * ), work( * )
16* ..
17*
18* Purpose
19* =======
20*
21* PDLANHS returns the value of the one norm, or the Frobenius norm,
22* or the infinity norm, or the element of largest absolute value of a
23* Hessenberg distributed matrix sub( A ) = A(IA:IA+N-1,JA:JA+N-1).
24*
25* PDLANHS returns the value
26*
27* ( max(abs(A(i,j))), NORM = 'M' or 'm' with IA <= i <= IA+N-1,
28* ( and JA <= j <= JA+N-1,
29* (
30* ( norm1( sub( A ) ), NORM = '1', 'O' or 'o'
31* (
32* ( normI( sub( A ) ), NORM = 'I' or 'i'
33* (
34* ( normF( sub( A ) ), NORM = 'F', 'f', 'E' or 'e'
35*
36* where norm1 denotes the one norm of a matrix (maximum column sum),
37* normI denotes the infinity norm of a matrix (maximum row sum) and
38* normF denotes the Frobenius norm of a matrix (square root of sum of
39* squares). Note that max(abs(A(i,j))) is not a matrix norm.
40*
41* Notes
42* =====
43*
44* Each global data object is described by an associated description
45* vector. This vector stores the information required to establish
46* the mapping between an object element and its corresponding process
47* and memory location.
48*
49* Let A be a generic term for any 2D block cyclicly distributed array.
50* Such a global array has an associated description vector DESCA.
51* In the following comments, the character _ should be read as
52* "of the global array".
53*
54* NOTATION STORED IN EXPLANATION
55* --------------- -------------- --------------------------------------
56* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
57* DTYPE_A = 1.
58* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
59* the BLACS process grid A is distribu-
60* ted over. The context itself is glo-
61* bal, but the handle (the integer
62* value) may vary.
63* M_A (global) DESCA( M_ ) The number of rows in the global
64* array A.
65* N_A (global) DESCA( N_ ) The number of columns in the global
66* array A.
67* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
68* the rows of the array.
69* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
70* the columns of the array.
71* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
72* row of the array A is distributed.
73* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
74* first column of the array A is
75* distributed.
76* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
77* array. LLD_A >= MAX(1,LOCr(M_A)).
78*
79* Let K be the number of rows or columns of a distributed matrix,
80* and assume that its process grid has dimension p x q.
81* LOCr( K ) denotes the number of elements of K that a process
82* would receive if K were distributed over the p processes of its
83* process column.
84* Similarly, LOCc( K ) denotes the number of elements of K that a
85* process would receive if K were distributed over the q processes of
86* its process row.
87* The values of LOCr() and LOCc() may be determined via a call to the
88* ScaLAPACK tool function, NUMROC:
89* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
90* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
91* An upper bound for these quantities may be computed by:
92* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
93* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
94*
95* Arguments
96* =========
97*
98* NORM (global input) CHARACTER
99* Specifies the value to be returned in PDLANHS as described
100* above.
101*
102* N (global input) INTEGER
103* The number of rows and columns to be operated on i.e the
104* number of rows and columns of the distributed submatrix
105* sub( A ). When N = 0, PDLANHS is set to zero. N >= 0.
106*
107* A (local input) DOUBLE PRECISION pointer into the local memory
108* to an array of dimension (LLD_A, LOCc(JA+N-1) ) containing
109* the local pieces of sub( A ).
110*
111* IA (global input) INTEGER
112* The row index in the global array A indicating the first
113* row of sub( A ).
114*
115* JA (global input) INTEGER
116* The column index in the global array A indicating the
117* first column of sub( A ).
118*
119* DESCA (global and local input) INTEGER array of dimension DLEN_.
120* The array descriptor for the distributed matrix A.
121*
122* WORK (local workspace) DOUBLE PRECISION array dimension (LWORK)
123* LWORK >= 0 if NORM = 'M' or 'm' (not referenced),
124* Nq0 if NORM = '1', 'O' or 'o',
125* Mp0 if NORM = 'I' or 'i',
126* 0 if NORM = 'F', 'f', 'E' or 'e' (not referenced),
127* where
128*
129* IROFFA = MOD( IA-1, MB_A ), ICOFFA = MOD( JA-1, NB_A ),
130* IAROW = INDXG2P( IA, MB_A, MYROW, RSRC_A, NPROW ),
131* IACOL = INDXG2P( JA, NB_A, MYCOL, CSRC_A, NPCOL ),
132* Np0 = NUMROC( N+IROFFA, MB_A, MYROW, IAROW, NPROW ),
133* Nq0 = NUMROC( N+ICOFFA, NB_A, MYCOL, IACOL, NPCOL ),
134*
135* INDXG2P and NUMROC are ScaLAPACK tool functions; MYROW,
136* MYCOL, NPROW and NPCOL can be determined by calling the
137* subroutine BLACS_GRIDINFO.
138*
139* =====================================================================
140*
141* .. Parameters ..
142 INTEGER block_cyclic_2d, csrc_, ctxt_, dlen_, dtype_,
143 $ lld_, mb_, m_, nb_, n_, rsrc_
144 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
145 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
146 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
147 DOUBLE PRECISION one, zero
148 parameter( one = 1.0d+0, zero = 0.0d+0 )
149* ..
150* .. Local Scalars ..
151 INTEGER iacol, iarow, ictxt, ii, iia, icoff, inxtrow,
152 $ ioffa, iroff, j, jb, jj, jja, jn, kk, lda, ll,
153 $ mycol, myrow, np, npcol, nprow, nq
154 DOUBLE PRECISION scale, sum, value
155* ..
156* .. Local Arrays ..
157 DOUBLE PRECISION rwork( 2 )
158* ..
159* .. External Subroutines ..
160 EXTERNAL blacs_gridinfo, dcombssq, dgebr2d,
161 $ dgebs2d, dgamx2d, dgsum2d, dlassq,
162 $ infog2l, pdtreecomb
163* ..
164* .. External Functions ..
165 LOGICAL lsame
166 INTEGER iceil, idamax, numroc
167 EXTERNAL lsame, iceil, idamax, numroc
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, max, min, mod, sqrt
171* ..
172* .. Executable Statements ..
173*
174* Get grid parameters.
175*
176 ictxt = desca( ctxt_ )
177 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
178*
179 CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol, iia, jja,
180 $ iarow, iacol )
181 iroff = mod( ia-1, desca( mb_ ) )
182 icoff = mod( ja-1, desca( nb_ ) )
183 np = numroc( n+iroff, desca( mb_ ), myrow, iarow, nprow )
184 nq = numroc( n+icoff, desca( nb_ ), mycol, iacol, npcol )
185 IF( myrow.EQ.iarow )
186 $ np = np - iroff
187 IF( mycol.EQ.iacol )
188 $ nq = nq - icoff
189 lda = desca( lld_ )
190 ioffa = ( jja - 1 ) * lda
191*
192 IF( n.EQ.0 ) THEN
193*
194 VALUE = zero
195*
196 ELSE IF( lsame( norm, 'M' ) ) THEN
197*
198 VALUE = zero
199*
200* Find max(abs(A(i,j))).
201*
202 ii = iia
203 jj = jja
204 jn = min( iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
205 jb = jn-ja+1
206*
207* Only one process row
208*
209 IF( nprow.EQ.1 ) THEN
210*
211* Handle first block of columns separately
212*
213 IF( mycol.EQ.iacol ) THEN
214 DO 20 ll = jj, jj+jb-1
215 DO 10 kk = iia, min( ii+ll-jj+1, iia+np-1 )
216 VALUE = max( VALUE, abs( a( ioffa+kk ) ) )
217 10 CONTINUE
218 ioffa = ioffa + lda
219 20 CONTINUE
220 jj = jj + jb
221 END IF
222*
223 iacol = mod( iacol+1, npcol )
224*
225* Loop over remaining block of columns
226*
227 DO 50 j = jn+1, ja+n-1, desca( nb_ )
228 jb = min( ja+n-j, desca( nb_ ) )
229*
230 IF( mycol.EQ.iacol ) THEN
231 DO 40 ll = jj, jj+jb-1
232 DO 30 kk = iia, min( ii+ll-jj+1, iia+np-1 )
233 VALUE = max( VALUE, abs( a( ioffa+kk ) ) )
234 30 CONTINUE
235 ioffa = ioffa + lda
236 40 CONTINUE
237 jj = jj + jb
238 END IF
239*
240 ii = ii + jb
241 iacol = mod( iacol+1, npcol )
242*
243 50 CONTINUE
244*
245 ELSE
246*
247* Handle first block of columns separately
248*
249 inxtrow = mod( iarow+1, nprow )
250 IF( mycol.EQ.iacol ) THEN
251 IF( myrow.EQ.iarow ) THEN
252 DO 70 ll = jj, jj + jb -1
253 DO 60 kk = iia, min( ii+ll-jj+1, iia+np-1 )
254 VALUE = max( VALUE, abs( a( ioffa+kk ) ) )
255 60 CONTINUE
256 ioffa = ioffa + lda
257 70 CONTINUE
258 ELSE
259 DO 90 ll = jj, jj+jb-1
260 DO 80 kk = iia, min( ii-1, iia+np-1 )
261 VALUE = max( VALUE, abs( a( ioffa+kk ) ) )
262 80 CONTINUE
263 ioffa = ioffa + lda
264 90 CONTINUE
265 IF( myrow.EQ.inxtrow .AND. ii.LE.iia+np-1 )
266 $ VALUE = max( VALUE, abs( a( ii+(jj+jb-2)*lda ) ) )
267 END IF
268 jj = jj + jb
269 END IF
270*
271 IF( myrow.EQ.iarow )
272 $ ii = ii + jb
273 iarow = inxtrow
274 iarow = mod( iarow+1, nprow )
275 iacol = mod( iacol+1, npcol )
276*
277* Loop over remaining block of columns
278*
279 DO 140 j = jn+1, ja+n-1, desca( nb_ )
280 jb = min( ja+n-j, desca( nb_ ) )
281*
282 IF( mycol.EQ.iacol ) THEN
283 IF( myrow.EQ.iarow ) THEN
284 DO 110 ll = jj, jj + jb -1
285 DO 100 kk = iia, min( ii+ll-jj+1, iia+np-1 )
286 VALUE = max( VALUE, abs( a( ioffa+kk ) ) )
287 100 CONTINUE
288 ioffa = ioffa + lda
289 110 CONTINUE
290 ELSE
291 DO 130 ll = jj, jj + jb -1
292 DO 120 kk = iia, min( ii-1, iia+np-1 )
293 VALUE = max( VALUE, abs( a( ioffa+kk ) ) )
294 120 CONTINUE
295 ioffa = ioffa + lda
296 130 CONTINUE
297 IF( myrow.EQ.inxtrow .AND. ii.LE.iia+np-1 )
298 $ VALUE = max( VALUE,
299 $ abs( a( ii+(jj+jb-2)*lda ) ) )
300 END IF
301 jj = jj + jb
302 END IF
303*
304 IF( myrow.EQ.iarow )
305 $ ii = ii + jb
306 iarow = inxtrow
307 iarow = mod( iarow+1, nprow )
308 iacol = mod( iacol+1, npcol )
309*
310 140 CONTINUE
311*
312 END IF
313*
314* Gather the intermediate results to process (0,0).
315*
316 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, VALUE, 1, kk, ll, -1,
317 $ 0, 0 )
318*
319 ELSE IF( lsame( norm, 'O' ) .OR. norm.EQ.'1' ) THEN
320*
321 VALUE = zero
322 ii = iia
323 jj = jja
324 jn = min( iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
325 jb = jn-ja+1
326*
327* Only one process row
328*
329 IF( nprow.EQ.1 ) THEN
330*
331* Handle first block of columns separately
332*
333 IF( mycol.EQ.iacol ) THEN
334 DO 160 ll = jj, jj+jb-1
335 sum = zero
336 DO 150 kk = iia, min( ii+ll-jj+1, iia+np-1 )
337 sum = sum + abs( a( ioffa+kk ) )
338 150 CONTINUE
339 ioffa = ioffa + lda
340 work( ll-jja+1 ) = sum
341 160 CONTINUE
342 jj = jj + jb
343 END IF
344*
345 iacol = mod( iacol+1, npcol )
346*
347* Loop over remaining block of columns
348*
349 DO 190 j = jn+1, ja+n-1, desca( nb_ )
350 jb = min( ja+n-j, desca( nb_ ) )
351*
352 IF( mycol.EQ.iacol ) THEN
353 DO 180 ll = jj, jj+jb-1
354 sum = zero
355 DO 170 kk = iia, min( ii+ll-jj+1, iia+np-1 )
356 sum = sum + abs( a( ioffa+kk ) )
357 170 CONTINUE
358 ioffa = ioffa + lda
359 work( ll-jja+1 ) = sum
360 180 CONTINUE
361 jj = jj + jb
362 END IF
363*
364 ii = ii + jb
365 iacol = mod( iacol+1, npcol )
366*
367 190 CONTINUE
368*
369 ELSE
370*
371* Handle first block of columns separately
372*
373 inxtrow = mod( iarow+1, nprow )
374 IF( mycol.EQ.iacol ) THEN
375 IF( myrow.EQ.iarow ) THEN
376 DO 210 ll = jj, jj + jb -1
377 sum = zero
378 DO 200 kk = iia, min( ii+ll-jj+1, iia+np-1 )
379 sum = sum + abs( a( ioffa+kk ) )
380 200 CONTINUE
381 ioffa = ioffa + lda
382 work( ll-jja+1 ) = sum
383 210 CONTINUE
384 ELSE
385 DO 230 ll = jj, jj + jb -1
386 sum = zero
387 DO 220 kk = iia, min( ii-1, iia+np-1 )
388 sum = sum + abs( a( ioffa+kk ) )
389 220 CONTINUE
390 ioffa = ioffa + lda
391 work( ll-jja+1 ) = sum
392 230 CONTINUE
393 IF( myrow.EQ.inxtrow .AND. ii.LE.iia+np-1 )
394 $ work( jj+jb-jja ) = work( jj+jb-jja ) +
395 $ abs( a( ii+(jj+jb-2)*lda ) )
396 END IF
397 jj = jj + jb
398 END IF
399*
400 IF( myrow.EQ.iarow )
401 $ ii = ii + jb
402 iarow = inxtrow
403 iarow = mod( iarow+1, nprow )
404 iacol = mod( iacol+1, npcol )
405*
406* Loop over remaining block of columns
407*
408 DO 280 j = jn+1, ja+n-1, desca( nb_ )
409 jb = min( ja+n-j, desca( nb_ ) )
410*
411 IF( mycol.EQ.iacol ) THEN
412 IF( myrow.EQ.iarow ) THEN
413 DO 250 ll = jj, jj + jb -1
414 sum = zero
415 DO 240 kk = iia, min( ii+ll-jj+1, iia+np-1 )
416 sum = sum + abs( a( ioffa+kk ) )
417 240 CONTINUE
418 ioffa = ioffa + lda
419 work( ll-jja+1 ) = sum
420 250 CONTINUE
421 ELSE
422 DO 270 ll = jj, jj + jb -1
423 sum = zero
424 DO 260 kk = iia, min( ii-1, iia+np-1 )
425 sum = sum + abs( a( ioffa+kk ) )
426 260 CONTINUE
427 ioffa = ioffa + lda
428 work( ll-jja+1 ) = sum
429 270 CONTINUE
430 IF( myrow.EQ.inxtrow .AND. ii.LE.iia+np-1 )
431 $ work( jj+jb-jja ) = work( jj+jb-jja ) +
432 $ abs( a( ii+(jj+jb-2)*lda ) )
433 END IF
434 jj = jj + jb
435 END IF
436*
437 IF( myrow.EQ.iarow )
438 $ ii = ii + jb
439 iarow = inxtrow
440 iarow = mod( iarow+1, nprow )
441 iacol = mod( iacol+1, npcol )
442*
443 280 CONTINUE
444*
445 END IF
446*
447* Find sum of global matrix columns and store on row 0 of
448* process grid
449*
450 CALL dgsum2d( ictxt, 'Columnwise', ' ', 1, nq, work, 1,
451 $ 0, mycol )
452*
453* Find maximum sum of columns for 1-norm
454*
455 IF( myrow.EQ.0 ) THEN
456 IF( nq.GT.0 ) THEN
457 VALUE = work( idamax( nq, work, 1 ) )
458 ELSE
459 VALUE = zero
460 END IF
461 CALL dgamx2d( ictxt, 'Rowwise', ' ', 1, 1, VALUE, 1, kk, ll,
462 $ -1, 0, 0 )
463 END IF
464*
465 ELSE IF( lsame( norm, 'I' ) ) THEN
466*
467 DO 290 kk = iia, iia+np-1
468 work( kk ) = zero
469 290 CONTINUE
470*
471 ii = iia
472 jj = jja
473 jn = min( iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
474 jb = jn-ja+1
475*
476* Only one process row
477*
478 IF( nprow.EQ.1 ) THEN
479*
480* Handle first block of columns separately
481*
482 IF( mycol.EQ.iacol ) THEN
483 DO 310 ll = jj, jj+jb-1
484 DO 300 kk = iia, min( ii+ll-jj+1, iia+np-1 )
485 work( kk-iia+1 ) = work( kk-iia+1 ) +
486 $ abs( a( ioffa+kk ) )
487 300 CONTINUE
488 ioffa = ioffa + lda
489 310 CONTINUE
490 jj = jj + jb
491 END IF
492*
493 iacol = mod( iacol+1, npcol )
494*
495* Loop over remaining block of columns
496*
497 DO 340 j = jn+1, ja+n-1, desca( nb_ )
498 jb = min( ja+n-j, desca( nb_ ) )
499*
500 IF( mycol.EQ.iacol ) THEN
501 DO 330 ll = jj, jj+jb-1
502 DO 320 kk = iia, min( ii+ll-jj+1, iia+np-1 )
503 work( kk-iia+1 ) = work( kk-iia+1 ) +
504 $ abs( a( ioffa+kk ) )
505 320 CONTINUE
506 ioffa = ioffa + lda
507 330 CONTINUE
508 jj = jj + jb
509 END IF
510*
511 ii = ii + jb
512 iacol = mod( iacol+1, npcol )
513*
514 340 CONTINUE
515*
516 ELSE
517*
518* Handle first block of columns separately
519*
520 inxtrow = mod( iarow+1, nprow )
521 IF( mycol.EQ.iacol ) THEN
522 IF( myrow.EQ.iarow ) THEN
523 DO 360 ll = jj, jj + jb -1
524 DO 350 kk = iia, min( ii+ll-jj+1, iia+np-1 )
525 work( kk-iia+1 ) = work( kk-iia+1 ) +
526 $ abs( a( ioffa+kk ) )
527 350 CONTINUE
528 ioffa = ioffa + lda
529 360 CONTINUE
530 ELSE
531 DO 380 ll = jj, jj + jb -1
532 DO 370 kk = iia, min( ii-1, iia+np-1 )
533 work( kk-iia+1 ) = work( kk-iia+1 ) +
534 $ abs( a( ioffa+kk ) )
535 370 CONTINUE
536 ioffa = ioffa + lda
537 380 CONTINUE
538 IF( myrow.EQ.inxtrow .AND. ii.LE.iia+np-1 )
539 $ work( ii-iia+1 ) = work( ii-iia+1 ) +
540 $ abs( a( ii+(jj+jb-2)*lda ) )
541 END IF
542 jj = jj + jb
543 END IF
544*
545 IF( myrow.EQ.iarow )
546 $ ii = ii + jb
547 iarow = inxtrow
548 iarow = mod( iarow+1, nprow )
549 iacol = mod( iacol+1, npcol )
550*
551* Loop over remaining block of columns
552*
553 DO 430 j = jn+1, ja+n-1, desca( nb_ )
554 jb = min( ja+n-j, desca( nb_ ) )
555*
556 IF( mycol.EQ.iacol ) THEN
557 IF( myrow.EQ.iarow ) THEN
558 DO 400 ll = jj, jj + jb -1
559 DO 390 kk = iia, min( ii+ll-jj+1, iia+np-1 )
560 work( kk-iia+1 ) = work( kk-iia+1 ) +
561 $ abs( a( ioffa+kk ) )
562 390 CONTINUE
563 ioffa = ioffa + lda
564 400 CONTINUE
565 ELSE
566 DO 420 ll = jj, jj + jb -1
567 DO 410 kk = iia, min( ii-1, iia+np-1 )
568 work( kk-iia+1 ) = work( kk-iia+1 ) +
569 $ abs(a(ioffa+kk))
570 410 CONTINUE
571 ioffa = ioffa + lda
572 420 CONTINUE
573 IF( myrow.EQ.inxtrow .AND. ii.LE.iia+np-1 )
574 $ work( ii-iia+1 ) = work( ii-iia+1 ) +
575 $ abs( a( ii+(jj+jb-2)*lda ) )
576 END IF
577 jj = jj + jb
578 END IF
579*
580 IF( myrow.EQ.iarow )
581 $ ii = ii + jb
582 iarow = inxtrow
583 iarow = mod( iarow+1, nprow )
584 iacol = mod( iacol+1, npcol )
585*
586 430 CONTINUE
587*
588 END IF
589*
590* Find sum of global matrix rows and store on column 0 of
591* process grid
592*
593 CALL dgsum2d( ictxt, 'Rowwise', ' ', np, 1, work, max( 1, np ),
594 $ myrow, 0 )
595*
596* Find maximum sum of rows for Infinity-norm
597*
598 IF( mycol.EQ.0 ) THEN
599 IF( np.GT.0 ) THEN
600 VALUE = work( idamax( np, work, 1 ) )
601 ELSE
602 VALUE = zero
603 END IF
604 CALL dgamx2d( ictxt, 'Columnwise', ' ', 1, 1, VALUE, 1, kk,
605 $ ll, -1, 0, 0 )
606 END IF
607*
608 ELSE IF( lsame( norm, 'F' ) .OR. lsame( norm, 'E' ) ) THEN
609*
610 scale = zero
611 sum = one
612 ii = iia
613 jj = jja
614 jn = min( iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
615 jb = jn-ja+1
616*
617* Only one process row
618*
619 IF( nprow.EQ.1 ) THEN
620*
621* Handle first block of columns separately
622*
623 IF( mycol.EQ.iacol ) THEN
624 DO 440 ll = jj, jj+jb-1
625 CALL dlassq( min( ii+ll-jj+1, iia+np-1 )-iia+1,
626 $ a( iia+ioffa ), 1, scale, sum )
627 ioffa = ioffa + lda
628 440 CONTINUE
629 jj = jj + jb
630 END IF
631*
632 iacol = mod( iacol+1, npcol )
633*
634* Loop over remaining block of columns
635*
636 DO 460 j = jn+1, ja+n-1, desca( nb_ )
637 jb = min( ja+n-j, desca( nb_ ) )
638*
639 IF( mycol.EQ.iacol ) THEN
640 DO 450 ll = jj, jj+jb-1
641 CALL dlassq( min( ii+ll-jj+1, iia+np-1 )-iia+1,
642 $ a( iia+ioffa ), 1, scale, sum )
643 ioffa = ioffa + lda
644 450 CONTINUE
645 jj = jj + jb
646 END IF
647*
648 ii = ii + jb
649 iacol = mod( iacol+1, npcol )
650*
651 460 CONTINUE
652*
653 ELSE
654*
655* Handle first block of columns separately
656*
657 inxtrow = mod( iarow+1, nprow )
658 IF( mycol.EQ.iacol ) THEN
659 IF( myrow.EQ.iarow ) THEN
660 DO 470 ll = jj, jj + jb -1
661 CALL dlassq( min( ii+ll-jj+1, iia+np-1 )-iia+1,
662 $ a( iia+ioffa ), 1, scale, sum )
663 ioffa = ioffa + lda
664 470 CONTINUE
665 ELSE
666 DO 480 ll = jj, jj + jb -1
667 CALL dlassq( min( ii-1, iia+np-1 )-iia+1,
668 $ a( iia+ioffa ), 1, scale, sum )
669 ioffa = ioffa + lda
670 480 CONTINUE
671 IF( myrow.EQ.inxtrow .AND. ii.LE.iia+np-1 )
672 $ CALL dlassq( 1, a( ii+(jj+jb-2)*lda ), 1,
673 $ scale, sum )
674 END IF
675 jj = jj + jb
676 END IF
677*
678 IF( myrow.EQ.iarow )
679 $ ii = ii + jb
680 iarow = inxtrow
681 iarow = mod( iarow+1, nprow )
682 iacol = mod( iacol+1, npcol )
683*
684* Loop over remaining block of columns
685*
686 DO 510 j = jn+1, ja+n-1, desca( nb_ )
687 jb = min( ja+n-j, desca( nb_ ) )
688*
689 IF( mycol.EQ.iacol ) THEN
690 IF( myrow.EQ.iarow ) THEN
691 DO 490 ll = jj, jj + jb -1
692 CALL dlassq( min( ii+ll-jj+1, iia+np-1 )-iia+1,
693 $ a( iia+ioffa ), 1, scale, sum )
694 ioffa = ioffa + lda
695 490 CONTINUE
696 ELSE
697 DO 500 ll = jj, jj + jb -1
698 CALL dlassq( min( ii-1, iia+np-1 )-iia+1,
699 $ a( iia+ioffa ), 1, scale, sum )
700 ioffa = ioffa + lda
701 500 CONTINUE
702 IF( myrow.EQ.inxtrow .AND. ii.LE.iia+np-1 )
703 $ CALL dlassq( 1, a( ii+(jj+jb-2)*lda ), 1,
704 $ scale, sum )
705 END IF
706 jj = jj + jb
707 END IF
708*
709 IF( myrow.EQ.iarow )
710 $ ii = ii + jb
711 iarow = inxtrow
712 iarow = mod( iarow+1, nprow )
713 iacol = mod( iacol+1, npcol )
714*
715 510 CONTINUE
716*
717 END IF
718*
719* Perform the global scaled sum
720*
721 rwork( 1 ) = scale
722 rwork( 2 ) = sum
723 CALL pdtreecomb( ictxt, 'All', 2, rwork, 0, 0, dcombssq )
724 VALUE = rwork( 1 ) * sqrt( rwork( 2 ) )
725*
726 END IF
727*
728 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
729 CALL dgebs2d( ictxt, 'All', ' ', 1, 1, VALUE, 1 )
730 ELSE
731 CALL dgebr2d( ictxt, 'All', ' ', 1, 1, VALUE, 1, 0, 0 )
732 END IF
733*
734 pdlanhs = VALUE
735*
736 RETURN
737*
738* End of PDLANHS
739*
740 END
iceil
integer function iceil(inum, idenom)
Definition iceil.f:2
infog2l
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
Definition infog2l.f:3
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition numroc.f:2
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pdlanhs
double precision function pdlanhs(norm, n, a, ia, ja, desca, work)
Definition pdlanhs.f:3
dcombssq
subroutine dcombssq(v1, v2)
Definition pdtreecomb.f:259
pdtreecomb
subroutine pdtreecomb(ictxt, scope, n, mine, rdest0, cdest0, subptr)
Definition pdtreecomb.f:3
lsame
logical function lsame(ca, cb)
Definition tools.f:1724