ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
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
max
#define max(A, B)
Definition: pcgemr.c:180
pdlanhs
double precision function pdlanhs(NORM, N, A, IA, JA, DESCA, WORK)
Definition: pdlanhs.f:3
pdtreecomb
subroutine pdtreecomb(ICTXT, SCOPE, N, MINE, RDEST0, CDEST0, SUBPTR)
Definition: pdtreecomb.f:3
infog2l
subroutine infog2l(GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
Definition: infog2l.f:3
lsame
logical function lsame(CA, CB)
Definition: tools.f:1724
numroc
integer function numroc(N, NB, IPROC, ISRCPROC, NPROCS)
Definition: numroc.f:2
dcombssq
subroutine dcombssq(V1, V2)
Definition: pdtreecomb.f:259
min
#define min(A, B)
Definition: pcgemr.c:181
iceil
integer function iceil(INUM, IDENOM)
Definition: iceil.f:2