131
132
133
134
135
136
137 CHARACTER DIAG, TRANS, UPLO
138 INTEGER INFO, LDB, N, NRHS
139
140
141 INTEGER IPIV( * )
142 COMPLEX A( * ), B( LDB, * )
143
144
145
146
147
148 COMPLEX ONE
149 parameter( one = ( 1.0e+0, 0.0e+0 ) )
150
151
152 LOGICAL NOUNIT
153 INTEGER J, K, KC, KCNEXT, KP
154 COMPLEX D11, D12, D21, D22, T1, T2
155
156
157 LOGICAL LSAME
159
160
162
163
164 INTRINSIC abs, conjg, max
165
166
167
168
169
170 info = 0
171 IF( .NOT.
lsame( uplo,
'U' ) .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
172 info = -1
173 ELSE IF( .NOT.
lsame( trans,
'N' ) .AND. .NOT.
lsame( trans,
'C' ) )
174 $ THEN
175 info = -2
176 ELSE IF( .NOT.
lsame( diag,
'U' ) .AND. .NOT.
lsame( diag,
'N' ) )
177 $ THEN
178 info = -3
179 ELSE IF( n.LT.0 ) THEN
180 info = -4
181 ELSE IF( ldb.LT.max( 1, n ) ) THEN
182 info = -8
183 END IF
184 IF( info.NE.0 ) THEN
185 CALL xerbla(
'CLAVHP ', -info )
186 RETURN
187 END IF
188
189
190
191 IF( n.EQ.0 )
192 $ RETURN
193
194 nounit =
lsame( diag,
'N' )
195
196
197
198
199
200 IF(
lsame( trans,
'N' ) )
THEN
201
202
203
204
205 IF(
lsame( uplo,
'U' ) )
THEN
206
207
208
209 k = 1
210 kc = 1
211 10 CONTINUE
212 IF( k.GT.n )
213 $ GO TO 30
214
215
216
217 IF( ipiv( k ).GT.0 ) THEN
218
219
220
221 IF( nounit )
222 $
CALL cscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
223
224
225
226 IF( k.GT.1 ) THEN
227
228
229
230 CALL cgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
231 $ ldb, b( 1, 1 ), ldb )
232
233
234
235 kp = ipiv( k )
236 IF( kp.NE.k )
237 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
238 END IF
239 kc = kc + k
240 k = k + 1
241 ELSE
242
243
244
245 kcnext = kc + k
246
247
248
249 IF( nounit ) THEN
250 d11 = a( kcnext-1 )
251 d22 = a( kcnext+k )
252 d12 = a( kcnext+k-1 )
253 d21 = conjg( d12 )
254 DO 20 j = 1, nrhs
255 t1 = b( k, j )
256 t2 = b( k+1, j )
257 b( k, j ) = d11*t1 + d12*t2
258 b( k+1, j ) = d21*t1 + d22*t2
259 20 CONTINUE
260 END IF
261
262
263
264 IF( k.GT.1 ) THEN
265
266
267
268 CALL cgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
269 $ ldb, b( 1, 1 ), ldb )
270 CALL cgeru( k-1, nrhs, one, a( kcnext ), 1,
271 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
272
273
274
275 kp = abs( ipiv( k ) )
276 IF( kp.NE.k )
277 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
278 END IF
279 kc = kcnext + k + 1
280 k = k + 2
281 END IF
282 GO TO 10
283 30 CONTINUE
284
285
286
287
288 ELSE
289
290
291
292 k = n
293 kc = n*( n+1 ) / 2 + 1
294 40 CONTINUE
295 IF( k.LT.1 )
296 $ GO TO 60
297 kc = kc - ( n-k+1 )
298
299
300
301
302 IF( ipiv( k ).GT.0 ) THEN
303
304
305
306
307
308 IF( nounit )
309 $
CALL cscal( nrhs, a( kc ), b( k, 1 ), ldb )
310
311
312
313 IF( k.NE.n ) THEN
314 kp = ipiv( k )
315
316
317
318 CALL cgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
319 $ ldb, b( k+1, 1 ), ldb )
320
321
322
323
324 IF( kp.NE.k )
325 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
326 END IF
327 k = k - 1
328
329 ELSE
330
331
332
333 kcnext = kc - ( n-k+2 )
334
335
336
337 IF( nounit ) THEN
338 d11 = a( kcnext )
339 d22 = a( kc )
340 d21 = a( kcnext+1 )
341 d12 = conjg( d21 )
342 DO 50 j = 1, nrhs
343 t1 = b( k-1, j )
344 t2 = b( k, j )
345 b( k-1, j ) = d11*t1 + d12*t2
346 b( k, j ) = d21*t1 + d22*t2
347 50 CONTINUE
348 END IF
349
350
351
352 IF( k.NE.n ) THEN
353
354
355
356 CALL cgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
357 $ ldb, b( k+1, 1 ), ldb )
358 CALL cgeru( n-k, nrhs, one, a( kcnext+2 ), 1,
359 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
360
361
362
363
364 kp = abs( ipiv( k ) )
365 IF( kp.NE.k )
366 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
367 END IF
368 kc = kcnext
369 k = k - 2
370 END IF
371 GO TO 40
372 60 CONTINUE
373 END IF
374
375
376
377
378
379 ELSE
380
381
382
383
384
385 IF(
lsame( uplo,
'U' ) )
THEN
386
387
388
389 k = n
390 kc = n*( n+1 ) / 2 + 1
391 70 IF( k.LT.1 )
392 $ GO TO 90
393 kc = kc - k
394
395
396
397 IF( ipiv( k ).GT.0 ) THEN
398 IF( k.GT.1 ) THEN
399
400
401
402 kp = ipiv( k )
403 IF( kp.NE.k )
404 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
405
406
407
408
409
410 CALL clacgv( nrhs, b( k, 1 ), ldb )
411 CALL cgemv(
'Conjugate', k-1, nrhs, one, b, ldb,
412 $ a( kc ), 1, one, b( k, 1 ), ldb )
413 CALL clacgv( nrhs, b( k, 1 ), ldb )
414 END IF
415 IF( nounit )
416 $
CALL cscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
417 k = k - 1
418
419
420
421 ELSE
422 kcnext = kc - ( k-1 )
423 IF( k.GT.2 ) THEN
424
425
426
427 kp = abs( ipiv( k ) )
428 IF( kp.NE.k-1 )
429 $
CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
430 $ ldb )
431
432
433
434 CALL clacgv( nrhs, b( k, 1 ), ldb )
435 CALL cgemv(
'Conjugate', k-2, nrhs, one, b, ldb,
436 $ a( kc ), 1, one, b( k, 1 ), ldb )
437 CALL clacgv( nrhs, b( k, 1 ), ldb )
438
439 CALL clacgv( nrhs, b( k-1, 1 ), ldb )
440 CALL cgemv(
'Conjugate', k-2, nrhs, one, b, ldb,
441 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
442 CALL clacgv( nrhs, b( k-1, 1 ), ldb )
443 END IF
444
445
446
447 IF( nounit ) THEN
448 d11 = a( kc-1 )
449 d22 = a( kc+k-1 )
450 d12 = a( kc+k-2 )
451 d21 = conjg( d12 )
452 DO 80 j = 1, nrhs
453 t1 = b( k-1, j )
454 t2 = b( k, j )
455 b( k-1, j ) = d11*t1 + d12*t2
456 b( k, j ) = d21*t1 + d22*t2
457 80 CONTINUE
458 END IF
459 kc = kcnext
460 k = k - 2
461 END IF
462 GO TO 70
463 90 CONTINUE
464
465
466
467
468
469 ELSE
470
471
472
473 k = 1
474 kc = 1
475 100 CONTINUE
476 IF( k.GT.n )
477 $ GO TO 120
478
479
480
481 IF( ipiv( k ).GT.0 ) THEN
482 IF( k.LT.n ) THEN
483
484
485
486 kp = ipiv( k )
487 IF( kp.NE.k )
488 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
489
490
491
492 CALL clacgv( nrhs, b( k, 1 ), ldb )
493 CALL cgemv(
'Conjugate', n-k, nrhs, one, b( k+1, 1 ),
494 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
495 CALL clacgv( nrhs, b( k, 1 ), ldb )
496 END IF
497 IF( nounit )
498 $
CALL cscal( nrhs, a( kc ), b( k, 1 ), ldb )
499 kc = kc + n - k + 1
500 k = k + 1
501
502
503
504 ELSE
505 kcnext = kc + n - k + 1
506 IF( k.LT.n-1 ) THEN
507
508
509
510 kp = abs( ipiv( k ) )
511 IF( kp.NE.k+1 )
512 $
CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
513 $ ldb )
514
515
516
517 CALL clacgv( nrhs, b( k+1, 1 ), ldb )
518 CALL cgemv(
'Conjugate', n-k-1, nrhs, one,
519 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
520 $ b( k+1, 1 ), ldb )
521 CALL clacgv( nrhs, b( k+1, 1 ), ldb )
522
523 CALL clacgv( nrhs, b( k, 1 ), ldb )
524 CALL cgemv(
'Conjugate', n-k-1, nrhs, one,
525 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
526 $ b( k, 1 ), ldb )
527 CALL clacgv( nrhs, b( k, 1 ), ldb )
528 END IF
529
530
531
532 IF( nounit ) THEN
533 d11 = a( kc )
534 d22 = a( kcnext )
535 d21 = a( kc+1 )
536 d12 = conjg( d21 )
537 DO 110 j = 1, nrhs
538 t1 = b( k, j )
539 t2 = b( k+1, j )
540 b( k, j ) = d11*t1 + d12*t2
541 b( k+1, j ) = d21*t1 + d22*t2
542 110 CONTINUE
543 END IF
544 kc = kcnext + ( n-k )
545 k = k + 2
546 END IF
547 GO TO 100
548 120 CONTINUE
549 END IF
550
551 END IF
552 RETURN
553
554
555
subroutine xerbla(srname, info)
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
subroutine cgeru(m, n, alpha, x, incx, y, incy, a, lda)
CGERU
subroutine clacgv(n, x, incx)
CLACGV conjugates a complex vector.
logical function lsame(ca, cb)
LSAME
subroutine cscal(n, ca, cx, incx)
CSCAL
subroutine cswap(n, cx, incx, cy, incy)
CSWAP