OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pclanhe.f File Reference

Go to the source code of this file.

Functions/Subroutines

real function pclanhe (norm, uplo, n, a, ia, ja, desca, work)

Function/Subroutine Documentation

◆ pclanhe()

real function pclanhe ( character norm,
character uplo,
integer n,
complex, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca,
real, dimension( * ) work )

Definition at line 1 of file pclanhe.f.

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, UPLO
11 INTEGER IA, JA, N
12* ..
13* .. Array Arguments ..
14 INTEGER DESCA( * )
15 REAL WORK( * )
16 COMPLEX A( * )
17* ..
18*
19* Purpose
20* =======
21*
22* PCLANHE returns the value of the one norm, or the Frobenius norm,
23* or the infinity norm, or the element of largest absolute value of a
24* complex hermitian distributed matrix sub(A) = A(IA:IA+N-1,JA:JA+N-1).
25*
26* PCLANHE returns the value
27*
28* ( max(abs(A(i,j))), NORM = 'M' or 'm' with IA <= i <= IA+N-1,
29* ( and JA <= j <= JA+N-1,
30* (
31* ( norm1( sub( A ) ), NORM = '1', 'O' or 'o'
32* (
33* ( normI( sub( A ) ), NORM = 'I' or 'i'
34* (
35* ( normF( sub( A ) ), NORM = 'F', 'f', 'E' or 'e'
36*
37* where norm1 denotes the one norm of a matrix (maximum column sum),
38* normI denotes the infinity norm of a matrix (maximum row sum) and
39* normF denotes the Frobenius norm of a matrix (square root of sum of
40* squares). Note that max(abs(A(i,j))) is not a matrix norm.
41*
42* Notes
43* =====
44*
45* Each global data object is described by an associated description
46* vector. This vector stores the information required to establish
47* the mapping between an object element and its corresponding process
48* and memory location.
49*
50* Let A be a generic term for any 2D block cyclicly distributed array.
51* Such a global array has an associated description vector DESCA.
52* In the following comments, the character _ should be read as
53* "of the global array".
54*
55* NOTATION STORED IN EXPLANATION
56* --------------- -------------- --------------------------------------
57* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
58* DTYPE_A = 1.
59* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
60* the BLACS process grid A is distribu-
61* ted over. The context itself is glo-
62* bal, but the handle (the integer
63* value) may vary.
64* M_A (global) DESCA( M_ ) The number of rows in the global
65* array A.
66* N_A (global) DESCA( N_ ) The number of columns in the global
67* array A.
68* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
69* the rows of the array.
70* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
71* the columns of the array.
72* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
73* row of the array A is distributed.
74* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
75* first column of the array A is
76* distributed.
77* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
78* array. LLD_A >= MAX(1,LOCr(M_A)).
79*
80* Let K be the number of rows or columns of a distributed matrix,
81* and assume that its process grid has dimension p x q.
82* LOCr( K ) denotes the number of elements of K that a process
83* would receive if K were distributed over the p processes of its
84* process column.
85* Similarly, LOCc( K ) denotes the number of elements of K that a
86* process would receive if K were distributed over the q processes of
87* its process row.
88* The values of LOCr() and LOCc() may be determined via a call to the
89* ScaLAPACK tool function, NUMROC:
90* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
91* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
92* An upper bound for these quantities may be computed by:
93* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
94* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
95*
96* Arguments
97* =========
98*
99* NORM (global input) CHARACTER
100* Specifies the value to be returned in PCLANHE as described
101* above.
102*
103* UPLO (global input) CHARACTER
104* Specifies whether the upper or lower triangular part of the
105* hermitian matrix sub( A ) is to be referenced.
106* = 'U': Upper triangular part of sub( A ) is referenced,
107* = 'L': Lower triangular part of sub( A ) is referenced.
108*
109* N (global input) INTEGER
110* The number of rows and columns to be operated on i.e the
111* number of rows and columns of the distributed submatrix
112* sub( A ). When N = 0, PCLANHE is set to zero. N >= 0.
113*
114* A (local input) COMPLEX pointer into the local memory
115* to an array of dimension (LLD_A, LOCc(JA+N-1)) containing the
116* local pieces of the hermitian distributed matrix sub( A ).
117* If UPLO = 'U', the leading N-by-N upper triangular part of
118* sub( A ) contains the upper triangular matrix which norm is
119* to be computed, and the strictly lower triangular part of
120* this matrix is not referenced. If UPLO = 'L', the leading
121* N-by-N lower triangular part of sub( A ) contains the lower
122* triangular matrix which norm is to be computed, and the
123* strictly upper triangular part of sub( A ) is not referenced.
124*
125* IA (global input) INTEGER
126* The row index in the global array A indicating the first
127* row of sub( A ).
128*
129* JA (global input) INTEGER
130* The column index in the global array A indicating the
131* first column of sub( A ).
132*
133* DESCA (global and local input) INTEGER array of dimension DLEN_.
134* The array descriptor for the distributed matrix A.
135*
136* WORK (local workspace) REAL array dimension (LWORK)
137* LWORK >= 0 if NORM = 'M' or 'm' (not referenced),
138* 2*Nq0+Np0+LDW if NORM = '1', 'O', 'o', 'I' or 'i',
139* where LDW is given by:
140* IF( NPROW.NE.NPCOL ) THEN
141* LDW = MB_A*CEIL(CEIL(Np0/MB_A)/(LCM/NPROW))
142* ELSE
143* LDW = 0
144* END IF
145* 0 if NORM = 'F', 'f', 'E' or 'e' (not referenced),
146*
147* where LCM is the least common multiple of NPROW and NPCOL
148* LCM = ILCM( NPROW, NPCOL ) and CEIL denotes the ceiling
149* operation (ICEIL).
150*
151* IROFFA = MOD( IA-1, MB_A ), ICOFFA = MOD( JA-1, NB_A ),
152* IAROW = INDXG2P( IA, MB_A, MYROW, RSRC_A, NPROW ),
153* IACOL = INDXG2P( JA, NB_A, MYCOL, CSRC_A, NPCOL ),
154* Np0 = NUMROC( N+IROFFA, MB_A, MYROW, IAROW, NPROW ),
155* Nq0 = NUMROC( N+ICOFFA, NB_A, MYCOL, IACOL, NPCOL ),
156*
157* ICEIL, ILCM, INDXG2P and NUMROC are ScaLAPACK tool functions;
158* MYROW, MYCOL, NPROW and NPCOL can be determined by calling
159* the subroutine BLACS_GRIDINFO.
160*
161* =====================================================================
162*
163* .. Parameters ..
164 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
165 $ LLD_, MB_, M_, NB_, N_, RSRC_
166 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
167 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
168 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
169 REAL ONE, ZERO
170 parameter( one = 1.0e+0, zero = 0.0e+0 )
171* ..
172* .. Local Scalars ..
173 INTEGER I, IAROW, IACOL, IB, ICOFF, ICTXT, ICURCOL,
174 $ ICURROW, II, IIA, IN, IROFF, ICSR, ICSR0,
175 $ IOFFA, IRSC, IRSC0, IRSR, IRSR0, JJ, JJA, K,
176 $ LDA, LL, MYCOL, MYROW, NP, NPCOL, NPROW, NQ
177 REAL ABSA, SCALE, SUM, VALUE
178* ..
179* .. Local Arrays ..
180 REAL RWORK( 2 )
181* ..
182* .. External Subroutines ..
183 EXTERNAL blacs_gridinfo, classq, pscol2row,
184 $ pstreecomb, saxpy, scombssq,
185 $ sgamx2d, sgsum2d, sgebr2d, sgebs2d
186* ..
187* .. External Functions ..
188 LOGICAL LSAME
189 INTEGER ICEIL, ISAMAX, NUMROC
190 EXTERNAL iceil, isamax, lsame, numroc
191* ..
192* .. Intrinsic Functions ..
193 INTRINSIC abs, max, min, mod, real, sqrt
194* ..
195* .. Executable Statements ..
196*
197* Get grid parameters and local indexes.
198*
199 ictxt = desca( ctxt_ )
200 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
201 CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol,
202 $ iia, jja, iarow, iacol )
203*
204 iroff = mod( ia-1, desca( mb_ ) )
205 icoff = mod( ja-1, desca( nb_ ) )
206 np = numroc( n+iroff, desca( mb_ ), myrow, iarow, nprow )
207 nq = numroc( n+icoff, desca( nb_ ), mycol, iacol, npcol )
208 icsr = 1
209 irsr = icsr + nq
210 irsc = irsr + nq
211 IF( myrow.EQ.iarow ) THEN
212 irsc0 = irsc + iroff
213 np = np - iroff
214 ELSE
215 irsc0 = irsc
216 END IF
217 IF( mycol.EQ.iacol ) THEN
218 icsr0 = icsr + icoff
219 irsr0 = irsr + icoff
220 nq = nq - icoff
221 ELSE
222 icsr0 = icsr
223 irsr0 = irsr
224 END IF
225 in = min( iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+n-1 )
226 lda = desca( lld_ )
227*
228* If the matrix is Hermitian, we address only a triangular portion
229* of the matrix. A sum of row (column) i of the complete matrix
230* can be obtained by adding along row i and column i of the the
231* triangular matrix, stopping/starting at the diagonal, which is
232* the point of reflection. The pictures below demonstrate this.
233* In the following code, the row sums created by --- rows below are
234* refered to as ROWSUMS, and the column sums shown by | are refered
235* to as COLSUMS. Infinity-norm = 1-norm = ROWSUMS+COLSUMS.
236*
237* UPLO = 'U' UPLO = 'L'
238* ____i______ ___________
239* |\ | | |\ |
240* | \ | | | \ |
241* | \ | | | \ |
242* | \|------| i i|---\ |
243* | \ | | |\ |
244* | \ | | | \ |
245* | \ | | | \ |
246* | \ | | | \ |
247* | \ | | | \ |
248* | \ | | | \ |
249* |__________\| |___|______\|
250* i
251*
252* II, JJ : local indices into array A
253* ICURROW : process row containing diagonal block
254* ICURCOL : process column containing diagonal block
255* IRSC0 : pointer to part of work used to store the ROWSUMS while
256* they are stored along a process column
257* IRSR0 : pointer to part of work used to store the ROWSUMS after
258* they have been transposed to be along a process row
259*
260 ii = iia
261 jj = jja
262*
263 IF( n.EQ.0 ) THEN
264*
265 VALUE = zero
266*
267 ELSE IF( lsame( norm, 'M' ) ) THEN
268*
269* Find max(abs(A(i,j))).
270*
271 VALUE = zero
272*
273 IF( lsame( uplo, 'u' ) ) THEN
274*
275* Handle first block separately
276*
277 IB = IN-IA+1
278*
279* Find COLMAXS
280*
281.EQ. IF( MYCOLIACOL ) THEN
282 DO 20 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
283.GT. IF( IIIIA ) THEN
284 DO 10 LL = IIA, II-1
285 VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
286 10 CONTINUE
287 END IF
288.EQ. IF( MYROWIAROW )
289 $ II = II + 1
290 20 CONTINUE
291*
292* Reset local indices so we can find ROWMAXS
293*
294.EQ. IF( MYROWIAROW )
295 $ II = II - IB
296*
297 END IF
298*
299* Find ROWMAXS
300*
301.EQ. IF( MYROWIAROW ) THEN
302 DO 40 K = II, II+IB-1
303.EQ. IF( MYCOLIACOL ) THEN
304.LE. IF( JJJJA+NQ-1 ) THEN
305 VALUE = MAX( VALUE,
306 $ ABS( REAL( A( K+(JJ-1)*LDA ) ) ) )
307 DO 30 LL = JJ*LDA, (JJA+NQ-2)*LDA, LDA
308 VALUE = MAX( VALUE, ABS( A( K+LL ) ) )
309 30 CONTINUE
310 END IF
311 ELSE
312.LE. IF( JJJJA+NQ-1 ) THEN
313 DO 35 LL = (JJ-1)*LDA, (JJA+NQ-2)*LDA, LDA
314 VALUE = MAX( VALUE, ABS( A( K+LL ) ) )
315 35 CONTINUE
316 END IF
317 END IF
318.EQ. IF( MYCOLIACOL )
319 $ JJ = JJ + 1
320 40 CONTINUE
321 II = II + IB
322.EQ. ELSE IF( MYCOLIACOL ) THEN
323 JJ = JJ + IB
324 END IF
325*
326 ICURROW = MOD( IAROW+1, NPROW )
327 ICURCOL = MOD( IACOL+1, NPCOL )
328*
329* Loop over the remaining rows/columns of the matrix.
330*
331 DO 90 I = IN+1, IA+N-1, DESCA( MB_ )
332 IB = MIN( DESCA( MB_ ), IA+N-I )
333*
334* Find COLMAXS
335*
336.EQ. IF( MYCOLICURCOL ) THEN
337 DO 60 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
338.GT. IF( IIIIA ) THEN
339 DO 50 LL = IIA, II-1
340 VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
341 50 CONTINUE
342 END IF
343.EQ. IF( MYROWICURROW )
344 $ II = II + 1
345 60 CONTINUE
346*
347* Reset local indices so we can find ROWMAXS
348*
349.EQ. IF( MYROWICURROW )
350 $ II = II - IB
351 END IF
352*
353* Find ROWMAXS
354*
355.EQ. IF( MYROWICURROW ) THEN
356 DO 80 K = II, II+IB-1
357.EQ. IF( MYCOLICURCOL ) THEN
358.LE. IF( JJJJA+NQ-1 ) THEN
359 VALUE = MAX( VALUE,
360 $ ABS( REAL( A( K+(JJ-1)*LDA ) ) ) )
361 DO 70 LL = JJ*LDA, (JJA+NQ-2)*LDA, LDA
362 VALUE = MAX( VALUE, ABS( A( K+LL ) ) )
363 70 CONTINUE
364 END IF
365 ELSE
366.LE. IF( JJJJA+NQ-1 ) THEN
367 DO 75 LL = (JJ-1)*LDA, (JJA+NQ-2)*LDA, LDA
368 VALUE = MAX( VALUE, ABS( A( K+LL ) ) )
369 75 CONTINUE
370 END IF
371 END IF
372.EQ. IF( MYCOLICURCOL )
373 $ JJ = JJ + 1
374 80 CONTINUE
375 II = II + IB
376.EQ. ELSE IF( MYCOLICURCOL ) THEN
377 JJ = JJ + IB
378 END IF
379 ICURROW = MOD( ICURROW+1, NPROW )
380 ICURCOL = MOD( ICURCOL+1, NPCOL )
381 90 CONTINUE
382*
383 ELSE
384*
385* Handle first block separately
386*
387 IB = IN-IA+1
388*
389* Find COLMAXS
390*
391.EQ. IF( MYCOLIACOL ) THEN
392 DO 110 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
393.EQ. IF( MYROWIAROW ) THEN
394.LE. IF( IIIIA+NP-1 ) THEN
395 VALUE = MAX( VALUE, ABS( REAL( A( II+K ) ) ) )
396 DO 100 LL = II+1, IIA+NP-1
397 VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
398 100 CONTINUE
399 END IF
400 ELSE
401.LE. IF( IIIIA+NP-1 ) THEN
402 DO 105 LL = II, IIA+NP-1
403 VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
404 105 CONTINUE
405 END IF
406 END IF
407.EQ. IF( MYROWIAROW )
408 $ II = II + 1
409 110 CONTINUE
410*
411* Reset local indices so we can find ROWMAXS
412*
413.EQ. IF( MYROWIAROW )
414 $ II = II - IB
415 END IF
416*
417* Find ROWMAXS
418*
419.EQ. IF( MYROWIAROW ) THEN
420 DO 130 K = 0, IB-1
421.GT. IF( JJJJA ) THEN
422 DO 120 LL = (JJA-1)*LDA, (JJ-2)*LDA, LDA
423 VALUE = MAX( VALUE, ABS( A( II+LL ) ) )
424 120 CONTINUE
425 END IF
426 II = II + 1
427.EQ. IF( MYCOLIACOL )
428 $ JJ = JJ + 1
429 130 CONTINUE
430.EQ. ELSE IF( MYCOLIACOL ) THEN
431 JJ = JJ + IB
432 END IF
433*
434 ICURROW = MOD( IAROW+1, NPROW )
435 ICURCOL = MOD( IACOL+1, NPCOL )
436*
437* Loop over rows/columns of global matrix.
438*
439 DO 180 I = IN+1, IA+N-1, DESCA( MB_ )
440 IB = MIN( DESCA( MB_ ), IA+N-I )
441*
442* Find COLMAXS
443*
444.EQ. IF( MYCOLICURCOL ) THEN
445 DO 150 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
446.EQ. IF( MYROWICURROW ) THEN
447.LE. IF( IIIIA+NP-1 ) THEN
448 VALUE = MAX( VALUE,
449 $ ABS( REAL( A( II+K ) ) ) )
450 DO 140 LL = II+1, IIA+NP-1
451 VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
452 140 CONTINUE
453 END IF
454 ELSE
455.LE. IF( IIIIA+NP-1 ) THEN
456 DO 145 LL = II, IIA+NP-1
457 VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
458 145 CONTINUE
459 END IF
460 END IF
461.EQ. IF( MYROWICURROW )
462 $ II = II + 1
463 150 CONTINUE
464*
465* Reset local indices so we can find ROWMAXS
466*
467.EQ. IF( MYROWICURROW )
468 $ II = II - IB
469 END IF
470*
471* Find ROWMAXS
472*
473.EQ. IF( MYROWICURROW ) THEN
474 DO 170 K = 0, IB-1
475.GT. IF( JJJJA ) THEN
476 DO 160 LL = (JJA-1)*LDA, (JJ-2)*LDA, LDA
477 VALUE = MAX( VALUE, ABS( A( II+LL ) ) )
478 160 CONTINUE
479 END IF
480 II = II + 1
481.EQ. IF( MYCOLICURCOL )
482 $ JJ = JJ + 1
483 170 CONTINUE
484.EQ. ELSE IF( MYCOLICURCOL ) THEN
485 JJ = JJ + IB
486 END IF
487 ICURROW = MOD( ICURROW+1, NPROW )
488 ICURCOL = MOD( ICURCOL+1, NPCOL )
489*
490 180 CONTINUE
491*
492 END IF
493*
494* Gather the result on process (IAROW,IACOL).
495*
496 CALL SGAMX2D( ICTXT, 'all', ' ', 1, 1, VALUE, 1, I, K, -1,
497 $ IAROW, IACOL )
498*
499 ELSE IF( LSAME( NORM, 'i.OR.' ) LSAME( NORM, 'o.OR.' )
500.EQ. $ NORM'1' ) THEN
501*
502* Find normI( sub( A ) ) ( = norm1( sub( A ) ), since sub( A ) is
503* hermitian).
504*
505 IF( LSAME( UPLO, 'u' ) ) THEN
506*
507* Handle first block separately
508*
509 IB = IN-IA+1
510*
511* Find COLSUMS
512*
513.EQ. IF( MYCOLIACOL ) THEN
514 IOFFA = ( JJ - 1 ) * LDA
515 DO 200 K = 0, IB-1
516 SUM = ZERO
517.GT. IF( IIIIA ) THEN
518 DO 190 LL = IIA, II-1
519 SUM = SUM + ABS( A( LL+IOFFA ) )
520 190 CONTINUE
521 END IF
522 IOFFA = IOFFA + LDA
523 WORK( JJ+K-JJA+ICSR0 ) = SUM
524.EQ. IF( MYROWIAROW )
525 $ II = II + 1
526 200 CONTINUE
527*
528* Reset local indices so we can find ROWSUMS
529*
530.EQ. IF( MYROWIAROW )
531 $ II = II - IB
532*
533 END IF
534*
535* Find ROWSUMS
536*
537.EQ. IF( MYROWIAROW ) THEN
538 DO 220 K = II, II+IB-1
539 SUM = ZERO
540.EQ. IF( MYCOLIACOL ) THEN
541.GT. IF( JJA+NQJJ ) THEN
542 SUM = ABS( REAL( A( K+(JJ-1)*LDA ) ) )
543 DO 210 LL = JJ*LDA, (JJA+NQ-2)*LDA, LDA
544 SUM = SUM + ABS( A( K+LL ) )
545 210 CONTINUE
546 END IF
547 ELSE
548.GT. IF( JJA+NQJJ ) THEN
549 DO 215 LL = (JJ-1)*LDA, (JJA+NQ-2)*LDA, LDA
550 SUM = SUM + ABS( A( K+LL ) )
551 215 CONTINUE
552 END IF
553 END IF
554 WORK( K-IIA+IRSC0 ) = SUM
555.EQ. IF( MYCOLIACOL )
556 $ JJ = JJ + 1
557 220 CONTINUE
558 II = II + IB
559.EQ. ELSE IF( MYCOLIACOL ) THEN
560 JJ = JJ + IB
561 END IF
562*
563 ICURROW = MOD( IAROW+1, NPROW )
564 ICURCOL = MOD( IACOL+1, NPCOL )
565*
566* Loop over remaining rows/columns of global matrix.
567*
568 DO 270 I = IN+1, IA+N-1, DESCA( MB_ )
569 IB = MIN( DESCA( MB_ ), IA+N-I )
570*
571* Find COLSUMS
572*
573.EQ. IF( MYCOLICURCOL ) THEN
574 IOFFA = ( JJ - 1 ) * LDA
575 DO 240 K = 0, IB-1
576 SUM = ZERO
577.GT. IF( IIIIA ) THEN
578 DO 230 LL = IIA, II-1
579 SUM = SUM + ABS( A( IOFFA+LL ) )
580 230 CONTINUE
581 END IF
582 IOFFA = IOFFA + LDA
583 WORK( JJ+K-JJA+ICSR0 ) = SUM
584.EQ. IF( MYROWICURROW )
585 $ II = II + 1
586 240 CONTINUE
587*
588* Reset local indices so we can find ROWSUMS
589*
590.EQ. IF( MYROWICURROW )
591 $ II = II - IB
592*
593 END IF
594*
595* Find ROWSUMS
596*
597.EQ. IF( MYROWICURROW ) THEN
598 DO 260 K = II, II+IB-1
599 SUM = ZERO
600.EQ. IF( MYCOLICURCOL ) THEN
601.GT. IF( JJA+NQJJ ) THEN
602 SUM = ABS( REAL( A( K+(JJ-1)*LDA ) ) )
603 DO 250 LL = JJ*LDA, (JJA+NQ-2)*LDA, LDA
604 SUM = SUM + ABS( A( K+LL ) )
605 250 CONTINUE
606 END IF
607 ELSE
608.GT. IF( JJA+NQJJ ) THEN
609 DO 255 LL = (JJ-1)*LDA, (JJA+NQ-2)*LDA, LDA
610 SUM = SUM + ABS( A( K+LL ) )
611 255 CONTINUE
612 END IF
613 END IF
614 WORK( K-IIA+IRSC0 ) = SUM
615.EQ. IF( MYCOLICURCOL )
616 $ JJ = JJ + 1
617 260 CONTINUE
618 II = II + IB
619.EQ. ELSE IF( MYCOLICURCOL ) THEN
620 JJ = JJ + IB
621 END IF
622*
623 ICURROW = MOD( ICURROW+1, NPROW )
624 ICURCOL = MOD( ICURCOL+1, NPCOL )
625*
626 270 CONTINUE
627*
628 ELSE
629*
630* Handle first block separately
631*
632 IB = IN-IA+1
633*
634* Find COLSUMS
635*
636.EQ. IF( MYCOLIACOL ) THEN
637 IOFFA = (JJ-1)*LDA
638 DO 290 K = 0, IB-1
639 SUM = ZERO
640.EQ. IF( MYROWIAROW ) THEN
641.GT. IF( IIA+NPII ) THEN
642 SUM = ABS( REAL( A( IOFFA+II ) ) )
643 DO 280 LL = II+1, IIA+NP-1
644 SUM = SUM + ABS( A( IOFFA+LL ) )
645 280 CONTINUE
646 END IF
647 ELSE
648 DO 285 LL = II, IIA+NP-1
649 SUM = SUM + ABS( A( IOFFA+LL ) )
650 285 CONTINUE
651 END IF
652 IOFFA = IOFFA + LDA
653 WORK( JJ+K-JJA+ICSR0 ) = SUM
654.EQ. IF( MYROWIAROW )
655 $ II = II + 1
656 290 CONTINUE
657*
658* Reset local indices so we can find ROWSUMS
659*
660.EQ. IF( MYROWIAROW )
661 $ II = II - IB
662*
663 END IF
664*
665* Find ROWSUMS
666*
667.EQ. IF( MYROWIAROW ) THEN
668 DO 310 K = II, II+IB-1
669 SUM = ZERO
670.GT. IF( JJJJA ) THEN
671 DO 300 LL = (JJA-1)*LDA, (JJ-2)*LDA, LDA
672 SUM = SUM + ABS( A( K+LL ) )
673 300 CONTINUE
674 END IF
675 WORK( K-IIA+IRSC0 ) = SUM
676.EQ. IF( MYCOLIACOL )
677 $ JJ = JJ + 1
678 310 CONTINUE
679 II = II + IB
680.EQ. ELSE IF( MYCOLIACOL ) THEN
681 JJ = JJ + IB
682 END IF
683*
684 ICURROW = MOD( IAROW+1, NPROW )
685 ICURCOL = MOD( IACOL+1, NPCOL )
686*
687* Loop over rows/columns of global matrix.
688*
689 DO 360 I = IN+1, IA+N-1, DESCA( MB_ )
690 IB = MIN( DESCA( MB_ ), IA+N-I )
691*
692* Find COLSUMS
693*
694.EQ. IF( MYCOLICURCOL ) THEN
695 IOFFA = ( JJ - 1 ) * LDA
696 DO 330 K = 0, IB-1
697 SUM = ZERO
698.EQ. IF( MYROWICURROW ) THEN
699.GT. IF( IIA+NPII ) THEN
700 SUM = ABS( REAL( A( II+IOFFA ) ) )
701 DO 320 LL = II+1, IIA+NP-1
702 SUM = SUM + ABS( A( LL+IOFFA ) )
703 320 CONTINUE
704.EQ. ELSE IF( IIIIA+NP-1 ) THEN
705 SUM = ABS( REAL( A( II+IOFFA ) ) )
706 END IF
707 ELSE
708 DO 325 LL = II, IIA+NP-1
709 SUM = SUM + ABS( A( LL+IOFFA ) )
710 325 CONTINUE
711 END IF
712 IOFFA = IOFFA + LDA
713 WORK( JJ+K-JJA+ICSR0 ) = SUM
714.EQ. IF( MYROWICURROW )
715 $ II = II + 1
716 330 CONTINUE
717*
718* Reset local indices so we can find ROWSUMS
719*
720.EQ. IF( MYROWICURROW )
721 $ II = II - IB
722*
723 END IF
724*
725* Find ROWSUMS
726*
727.EQ. IF( MYROWICURROW ) THEN
728 DO 350 K = II, II+IB-1
729 SUM = ZERO
730.GT. IF( JJJJA ) THEN
731 DO 340 LL = (JJA-1)*LDA, (JJ-2)*LDA, LDA
732 SUM = SUM + ABS( A( K+LL ) )
733 340 CONTINUE
734 END IF
735 WORK(K-IIA+IRSC0) = SUM
736.EQ. IF( MYCOLICURCOL )
737 $ JJ = JJ + 1
738 350 CONTINUE
739 II = II + IB
740.EQ. ELSE IF( MYCOLICURCOL ) THEN
741 JJ = JJ + IB
742 END IF
743*
744 ICURROW = MOD( ICURROW+1, NPROW )
745 ICURCOL = MOD( ICURCOL+1, NPCOL )
746*
747 360 CONTINUE
748 END IF
749*
750* After calls to SGSUM2D, process row 0 will have global
751* COLSUMS and process column 0 will have global ROWSUMS.
752* Transpose ROWSUMS and add to COLSUMS to get global row/column
753* sum, the max of which is the infinity or 1 norm.
754*
755.EQ. IF( MYCOLIACOL )
756 $ NQ = NQ + ICOFF
757 CALL SGSUM2D( ICTXT, 'columnwise', ' ', 1, NQ, WORK( ICSR ), 1,
758 $ IAROW, MYCOL )
759.EQ. IF( MYROWIAROW )
760 $ NP = NP + IROFF
761 CALL SGSUM2D( ICTXT, 'rowwise', ' ', NP, 1, WORK( IRSC ),
762 $ MAX( 1, NP ), MYROW, IACOL )
763*
764 CALL PSCOL2ROW( ICTXT, N, 1, DESCA( MB_ ), WORK( IRSC ),
765 $ MAX( 1, NP ), WORK( IRSR ), MAX( 1, NQ ),
766 $ IAROW, IACOL, IAROW, IACOL, WORK( IRSC+NP ) )
767*
768.EQ. IF( MYROWIAROW ) THEN
769.EQ. IF( MYCOLIACOL )
770 $ NQ = NQ - ICOFF
771 CALL SAXPY( NQ, ONE, WORK( IRSR0 ), 1, WORK( ICSR0 ), 1 )
772.LT. IF( NQ1 ) THEN
773 VALUE = ZERO
774 ELSE
775 VALUE = WORK( ISAMAX( NQ, WORK( ICSR0 ), 1 ) )
776 END IF
777 CALL SGAMX2D( ICTXT, 'rowwise', ' ', 1, 1, VALUE, 1, I, K,
778 $ -1, IAROW, IACOL )
779 END IF
780*
781 ELSE IF( LSAME( NORM, 'f.OR.' ) LSAME( NORM, 'e' ) ) THEN
782*
783* Find normF( sub( A ) ).
784*
785 SCALE = ZERO
786 SUM = ONE
787*
788* Add off-diagonal entries, first
789*
790 IF( LSAME( UPLO, 'u' ) ) THEN
791*
792* Handle first block separately
793*
794 IB = IN-IA+1
795*
796.EQ. IF( MYCOLIACOL ) THEN
797 DO 370 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
798 CALL CLASSQ( II-IIA, A( IIA+K ), 1, SCALE, SUM )
799 CALL CLASSQ( II-IIA, A( IIA+K ), 1, SCALE, SUM )
800.EQ. IF( MYROWIAROW ) THEN
801.NE. IF( REAL( A( II+K ) )ZERO ) THEN
802 ABSA = ABS( REAL( A( II+K ) ) )
803.LT. IF( SCALEABSA ) THEN
804 SUM = ONE + SUM * ( SCALE / ABSA )**2
805 SCALE = ABSA
806 ELSE
807 SUM = SUM + ( ABSA / SCALE )**2
808 END IF
809 END IF
810 II = II + 1
811 END IF
812 370 CONTINUE
813*
814 JJ = JJ + IB
815.EQ. ELSE IF( MYROWIAROW ) THEN
816 II = II + IB
817 END IF
818*
819 ICURROW = MOD( IAROW+1, NPROW )
820 ICURCOL = MOD( IACOL+1, NPCOL )
821*
822* Loop over rows/columns of global matrix.
823*
824 DO 390 I = IN+1, IA+N-1, DESCA( MB_ )
825 IB = MIN( DESCA( MB_ ), IA+N-I )
826*
827.EQ. IF( MYCOLICURCOL ) THEN
828 DO 380 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
829 CALL CLASSQ( II-IIA, A( IIA+K ), 1, SCALE, SUM )
830 CALL CLASSQ( II-IIA, A( IIA+K ), 1, SCALE, SUM )
831.EQ. IF( MYROWICURROW ) THEN
832.NE. IF( REAL( A( II+K ) )ZERO ) THEN
833 ABSA = ABS( REAL( A( II+K ) ) )
834.LT. IF( SCALEABSA ) THEN
835 SUM = ONE + SUM*( SCALE / ABSA )**2
836 SCALE = ABSA
837 ELSE
838 SUM = SUM + ( ABSA / SCALE )**2
839 END IF
840 END IF
841 II = II + 1
842 END IF
843 380 CONTINUE
844*
845 JJ = JJ + IB
846.EQ. ELSE IF( MYROWICURROW ) THEN
847 II = II + IB
848 END IF
849*
850 ICURROW = MOD( ICURROW+1, NPROW )
851 ICURCOL = MOD( ICURCOL+1, NPCOL )
852*
853 390 CONTINUE
854*
855 ELSE
856*
857* Handle first block separately
858*
859 IB = IN-IA+1
860*
861.EQ. IF( MYCOLIACOL ) THEN
862 DO 400 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
863.EQ. IF( MYROWIAROW ) THEN
864.NE. IF( REAL( A( II+K ) )ZERO ) THEN
865 ABSA = ABS( REAL( A( II+K ) ) )
866.LT. IF( SCALEABSA ) THEN
867 SUM = ONE + SUM * ( SCALE / ABSA )**2
868 SCALE = ABSA
869 ELSE
870 SUM = SUM + ( ABSA / SCALE )**2
871 END IF
872 END IF
873 II = II + 1
874 END IF
875 CALL CLASSQ( IIA+NP-II, A( II+K ), 1, SCALE, SUM )
876 CALL CLASSQ( IIA+NP-II, A( II+K ), 1, SCALE, SUM )
877 400 CONTINUE
878*
879 JJ = JJ + IB
880.EQ. ELSE IF( MYROWIAROW ) THEN
881 II = II + IB
882 END IF
883*
884 ICURROW = MOD( IAROW+1, NPROW )
885 ICURCOL = MOD( IACOL+1, NPCOL )
886*
887* Loop over rows/columns of global matrix.
888*
889 DO 420 I = IN+1, IA+N-1, DESCA( MB_ )
890 IB = MIN( DESCA( MB_ ), IA+N-I )
891*
892.EQ. IF( MYCOLICURCOL ) THEN
893 DO 410 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
894.EQ. IF( MYROWICURROW ) THEN
895.NE. IF( REAL( A( II+K ) )ZERO ) THEN
896 ABSA = ABS( REAL( A( II+K ) ) )
897.LT. IF( SCALEABSA ) THEN
898 SUM = ONE + SUM * ( SCALE / ABSA )**2
899 SCALE = ABSA
900 ELSE
901 SUM = SUM + ( ABSA / SCALE )**2
902 END IF
903 END IF
904 II = II + 1
905 END IF
906 CALL CLASSQ( IIA+NP-II, A( II+K ), 1, SCALE, SUM )
907 CALL CLASSQ( IIA+NP-II, A( II+K ), 1, SCALE, SUM )
908 410 CONTINUE
909*
910 JJ = JJ + IB
911.EQ. ELSE IF( MYROWICURROW ) THEN
912 II = II + IB
913 END IF
914*
915 ICURROW = MOD( ICURROW+1, NPROW )
916 ICURCOL = MOD( ICURCOL+1, NPCOL )
917*
918 420 CONTINUE
919*
920 END IF
921*
922* Perform the global scaled sum
923*
924 RWORK( 1 ) = SCALE
925 RWORK( 2 ) = SUM
926*
927 CALL PSTREECOMB( ICTXT, 'all', 2, RWORK, IAROW, IACOL,
928 $ SCOMBSSQ )
929 VALUE = RWORK( 1 ) * SQRT( RWORK( 2 ) )
930*
931 END IF
932*
933* Broadcast the result to the other processes
934*
935.EQ..AND..EQ. IF( MYROWIAROW MYCOLIACOL ) THEN
936 CALL SGEBS2D( ICTXT, 'all', ' ', 1, 1, VALUE, 1 )
937 ELSE
938 CALL SGEBR2D( ICTXT, 'all', ' ', 1, 1, VALUE, 1, IAROW,
939 $ IACOL )
940 END IF
941*
942 PCLANHE = VALUE
943*
944 RETURN
945*
946* End of PCLANHE
947*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
classq
subroutine classq(n, x, incx, scl, sumsq)
CLASSQ updates a sum of squares represented in scaled form.
Definition classq.f90:137
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
saxpy
subroutine saxpy(n, sa, sx, incx, sy, incy)
SAXPY
Definition saxpy.f:89
iceil
integer function iceil(inum, idenom)
Definition iceil.f:2
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
sgebs2d
subroutine sgebs2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1072
sgebr2d
subroutine sgebr2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1113
infog2l
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
Definition mpi.f:937
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition mpi.f:786
pscol2row
subroutine pscol2row(ictxt, m, n, nb, vs, ldvs, vd, ldvd, rsrc, csrc, rdest, cdest, work)
Definition pscol2row.f:3
pstreecomb
subroutine pstreecomb(ictxt, scope, n, mine, rdest0, cdest0, subptr)
Definition pstreecomb.f:3
scombssq
subroutine scombssq(v1, v2)
Definition pstreecomb.f:258