2
3
4
5
6
7
8
9 INTEGER IA, JA, LWORK, N
10
11
12 INTEGER DESC( * )
13 DOUBLE PRECISION ( * ), BYCOL( * ), WORK( LWORK )
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119 INTEGER BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
120 $ MB_, NB_, RSRC_, CSRC_, LLD_
121 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
122 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
123 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
124
125
126 INTEGER ALLI, BUFLEN, I, II, MYCOL, MYROW, NB, NPCOL,
127 $ NPROW, PCOL
128
129
130
131 INTEGER NUMROC
133
134
135
137
138
140
141
142
143 IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
144 $ rsrc_.LT.0 )RETURN
145
147 nb = desc( mb_ )
148
149
150 DO 30 pcol = 0, npcol - 1
151 buflen =
numroc( n, nb, pcol, 0, npcol )
152 IF( mycol.EQ.pcol ) THEN
153 CALL dcopy( buflen, bycol, 1, work, 1 )
154 CALL dgebs2d( desc( ctxt_ ),
'R',
' ', 1, buflen, work, 1 )
155 ELSE
156 CALL dgebr2d( desc( ctxt_ ),
'R',
' ', 1, buflen, work, 1,
157 $ myrow, pcol )
158 END IF
159
160 alli = pcol*nb
161 DO 20 ii = 1, buflen, nb
162 DO 10 i = 1,
min( nb, buflen-ii+1 )
163 byall( alli+i ) = work( ii-1+i )
164 10 CONTINUE
165 alli = alli + nb*npcol
166 20 CONTINUE
167 30 CONTINUE
168
169 RETURN
170
171
172
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
subroutine dgebs2d(contxt, scope, top, m, n, a, lda)
subroutine dgebr2d(contxt, scope, top, m, n, a, lda)
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
integer function numroc(n, nb, iproc, isrcproc, nprocs)