4
5
6
7
8
9
10
11 CHARACTER DIAG, NORMIN, TRANS, UPLO
12 INTEGER IA, IX, JA, JX, N
13 REAL SCALE
14
15
16 INTEGER DESCA( * ), DESCX( * )
17 REAL CNORM( * )
18 COMPLEX A( * ), X( * ), WORK( * )
19
20
21
22
23
24
25
26
27
28
29
30 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
31 $ LLD_, MB_, M_, NB_, N_, RSRC_
32 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
33 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
34 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
35 REAL ONE
36 parameter( one = 1.0e+0 )
37
38
39 INTEGER ICTXT, IIX, IROFF, JJX, MYCOL, MYROW, NP,
40 $ NPCOL, NPROW, LDX, IXCOL, IXROW
41
42
43 INTEGER NUMROC
45
46
47 EXTERNAL blacs_gridinfo, cgebr2d, cgebs2d,
infog2l,
48 $ pctrsv
49
50
51
52
53
54 ictxt = desca( ctxt_ )
55 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
56
57
58
59 IF( n.EQ.0 )
60 $ RETURN
61
62
63
64 scale = one
65 CALL pctrsv( uplo, trans, diag, n, a, ia, ja, desca, x, ix, jx,
66 $ descx, 1 )
67
68 CALL infog2l( ix, jx, descx, nprow, npcol, myrow, mycol, iix, jjx,
69 $ ixrow, ixcol )
70 ldx = descx( lld_ )
71 iroff = mod( ix-1, descx(mb_) )
72 np =
numroc( n+iroff, descx( mb_ ), myrow, ixrow, nprow )
73 IF( myrow.EQ.ixrow )
74 $ np = np - iroff
75 IF( mycol.EQ.ixcol ) THEN
76 CALL cgebs2d( ictxt, 'R', ' ', np, 1, x( iix+(jjx-1)*ldx ),
77 $ ldx )
78 ELSE
79 CALL cgebr2d( ictxt, 'R', ' ', np, 1, x( iix+(jjx-1)*ldx ),
80 $ ldx, myrow, ixcol )
81 END IF
82
83 RETURN
84
85
86
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
integer function numroc(n, nb, iproc, isrcproc, nprocs)