3
4
5
6
7
8
9
10 CHARACTER UPLO
11 INTEGER IA, IB, JA, JB, M, N
12
13
14 INTEGER DESCA( * ), DESCB( * )
15 COMPLEX A( * ), B( * )
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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
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
148
149 INTEGER I, IAA, IBB, IBLK, IN, ITMP, J, JAA, JBB,
150 $ JBLK, JN, JTMP
151
152
154
155
156 LOGICAL LSAME
157 INTEGER ICEIL
159
160
162
163
164
165 IF( m.EQ.0 .OR. n.EQ.0 )
166 $ RETURN
167
168 in =
min(
iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
169 jn =
min(
iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
170
171 IF( m.LE.( desca( mb_ ) - mod( ia-1, desca( mb_ ) ) ) .OR.
172 $ n.LE.( desca( nb_ ) - mod( ja-1, desca( nb_ ) ) ) ) THEN
173 CALL pclacp2( uplo, m, n, a, ia, ja, desca,
174 $ b, ib, jb, descb )
175 ELSE
176
177 IF(
lsame( uplo,
'U' ) )
THEN
178 CALL pclacp2( uplo, in-ia+1, n, a, ia, ja, desca,
179 $ b, ib, jb, descb )
180 DO 10 i = in+1, ia+m-1, desca( mb_ )
181 itmp = i-ia
182 iblk =
min( desca( mb_ ), m-itmp )
183 ibb = ib + itmp
184 jbb = jb + itmp
185 jaa = ja + itmp
186 CALL pclacp2( uplo, iblk, n-itmp, a, i, jaa, desca,
187 $ b, ibb, jbb, descb )
188 10 CONTINUE
189 ELSE IF(
lsame( uplo,
'L' ) )
THEN
190 CALL pclacp2( uplo, m, jn-ja+1, a, ia, ja, desca,
191 $ b, ib, jb, descb )
192 DO 20 j = jn+1, ja+n-1, desca( nb_ )
193 jtmp = j-ja
194 jblk =
min( desca( nb_ ), n-jtmp )
195 ibb = ib + jtmp
196 jbb = jb + jtmp
197 iaa = ia + jtmp
198 CALL pclacp2( uplo, m-jtmp, jblk, a, iaa, j, desca,
199 $ b, ibb, jbb, descb )
200 20 CONTINUE
201 ELSE
202 IF( m.LE.n ) THEN
203 CALL pclacp2( uplo, in-ia+1, n, a, ia, ja, desca,
204 $ b, ib, jb, descb )
205 DO 30 i = in+1, ia+m-1, desca( mb_ )
206 itmp = i-ia
207 iblk =
min( desca( mb_ ), m-itmp )
208 ibb = ib+itmp
209 CALL pclacp2( uplo, iblk, n, a, i, ja, desca,
210 $ b, ibb, jb, descb )
211 30 CONTINUE
212 ELSE
213 CALL pclacp2( uplo, m, jn-ja+1, a, ia, ja, desca,
214 $ b, ib, jb, descb )
215 DO 40 j = jn+1, ja+n-1, desca( nb_ )
216 jtmp = j-ja
217 jblk =
min( desca( nb_ ), n-jtmp )
218 jbb = jb+jtmp
219 CALL pclacp2( uplo, m, jblk, a, ia, j, desca,
220 $ b, ib, jbb, descb )
221 40 CONTINUE
222 END IF
223 END IF
224
225 END IF
226
227 RETURN
228
229
230
integer function iceil(inum, idenom)
subroutine pclacp2(uplo, m, n, a, ia, ja, desca, b, ib, jb, descb)