2
3
4
5
6
7
8
9 CHARACTER UPLO
10 INTEGER IA, JA, M, N
11 DOUBLE PRECISION ALPHA, BETA
12
13
14 INTEGER DESCA( * )
15 DOUBLE PRECISION A( * )
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 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
133 $ LLD_, MB_, M_, NB_, N_, RSRC_
134 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
135 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
136 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
137
138
139 INTEGER I, IAA, IBLK, IN, ITMP, J, JAA, JBLK, JN, JTMP
140
141
143
144
145 LOGICAL LSAME
146 INTEGER ICEIL
148
149
151
152
153
154 IF( m.EQ.0 .OR. n.EQ.0 )
155 $ RETURN
156
157 IF( m.LE.( desca( mb_ ) - mod( ia-1, desca( mb_ ) ) ) .OR.
158 $ n.LE.( desca( nb_ ) - mod( ja-1, desca( nb_ ) ) ) ) THEN
159 CALL pdlase2( uplo, m, n, alpha, beta, a, ia, ja, desca )
160 ELSE
161
162 IF(
lsame( uplo,
'U' ) )
THEN
163 in =
min(
iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
164 CALL pdlase2( uplo, in-ia+1, n, alpha, beta, a, ia, ja,
165 $ desca )
166 DO 10 i = in+1, ia+m-1, desca( mb_ )
167 itmp = i-ia
168 iblk =
min( desca( mb_ ), m-itmp )
169 jaa = ja + itmp
170 CALL pdlase2( uplo, iblk, n-itmp, alpha, beta,
171 $ a, i, jaa, desca )
172 10 CONTINUE
173 ELSE IF(
lsame( uplo,
'L' ) )
THEN
174 jn =
min(
iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
175 CALL pdlase2( uplo, m, jn-ja+1, alpha, beta, a, ia, ja,
176 $ desca )
177 DO 20 j = jn+1, ja+n-1, desca( nb_ )
178 jtmp = j-ja
179 jblk =
min( desca( nb_ ), n-jtmp )
180 iaa = ia + jtmp
181 CALL pdlase2( uplo, m-jtmp, jblk, alpha, beta, a, iaa,
182 $ j, desca )
183 20 CONTINUE
184 ELSE
185 IF( m.LE.n ) THEN
186 in =
min(
iceil( ia, desca( mb_ ) ) * desca( mb_ ),
187 $ ia+m-1 )
188 CALL pdlase2( uplo, in-ia+1, n, alpha, beta, a, ia,
189 $ ja, desca )
190 DO 30 i = in+1, ia+m-1, desca( mb_ )
191 itmp = i-ia
192 iblk =
min( desca( mb_ ), m-itmp )
193 CALL pdlase2( uplo, iblk, i-ia, alpha, alpha, a, i,
194 $ ja, desca )
195 CALL pdlase2( uplo, iblk, n-i+ia, alpha, beta, a, i,
196 $ ja+i-ia, desca )
197 30 CONTINUE
198 ELSE
199 jn =
min(
iceil( ja, desca( nb_ ) ) * desca( nb_ ),
200 $ ja+n-1 )
201 CALL pdlase2( uplo, m, jn-ja+1, alpha, beta, a, ia,
202 $ ja, desca )
203 DO 40 j = jn+1, ja+n-1, desca( nb_ )
204 jtmp = j-ja
205 jblk =
min( desca( nb_ ), n-jtmp )
206 CALL pdlase2( uplo, j-ja, jblk, alpha, alpha, a, ia,
207 $ j, desca )
208 CALL pdlase2( uplo, m-j+ja, jblk, alpha, beta, a,
209 $ ia+j-ja, j, desca )
210 40 CONTINUE
211 END IF
212 END IF
213
214 END IF
215
216 RETURN
217
218
219
integer function iceil(inum, idenom)
subroutine pdlase2(uplo, m, n, alpha, beta, a, ia, ja, desca)