3
4
5
6
7
8
9
10 CHARACTER UPLO
11 INTEGER BW, IB, INFO, JA, LAF, LWORK, N, NRHS
12
13
14 INTEGER DESCA( * ), DESCB( * )
15 REAL A( * ), AF( * ), B( * ), WORK( * )
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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362 INTEGER INT_ONE
363 parameter( int_one = 1 )
364 INTEGER DESCMULT, BIGNUM
365 parameter( descmult = 100, bignum = descmult*descmult )
366 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
367 $ LLD_, MB_, M_, NB_, N_, RSRC_
368 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
369 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
370 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
371
372
373 INTEGER CSRC, FIRST_PROC, ICTXT, ICTXT_NEW, ICTXT_SAVE,
374 $ IDUM1, IDUM3, JA_NEW, LLDA, LLDB, MYCOL, MYROW,
375 $ NB, NP, NPCOL, NPROW, NP_SAVE, PART_OFFSET,
376 $ RETURN_CODE, STORE_M_B, STORE_N_A,
377 $ WORK_SIZE_MIN
378
379
380 INTEGER DESCA_1XP( 7 ), DESCB_PX1( 7 ),
381 $ PARAM_CHECK( 16, 3 )
382
383
386
387
388 LOGICAL LSAME
390
391
392 INTRINSIC ichar, mod
393
394
395
396
397
398 info = 0
399
400
401
402
403 desca_1xp( 1 ) = 501
404 descb_px1( 1 ) = 502
405
407
408 IF( return_code.NE.0 ) THEN
409 info = -( 7*100+2 )
410 END IF
411
413
414 IF( return_code.NE.0 ) THEN
415 info = -( 10*100+2 )
416 END IF
417
418
419
420
421 IF( desca_1xp( 2 ).NE.descb_px1( 2 ) ) THEN
422 info = -( 10*100+2 )
423 END IF
424
425
426
427
428
429 IF( desca_1xp( 4 ).NE.descb_px1( 4 ) ) THEN
430 info = -( 10*100+4 )
431 END IF
432
433
434
435 IF( desca_1xp( 5 ).NE.descb_px1( 5 ) ) THEN
436 info = -( 10*100+5 )
437 END IF
438
439
440
441 ictxt = desca_1xp( 2 )
442 csrc = desca_1xp( 5 )
443 nb = desca_1xp( 4 )
444 llda = desca_1xp( 6 )
445 store_n_a = desca_1xp( 3 )
446 lldb = descb_px1( 6 )
447 store_m_b = descb_px1( 3 )
448
449
450
451
452 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
453 np = nprow*npcol
454
455
456
457 IF(
lsame( uplo,
'U' ) )
THEN
458 idum1 = ichar( 'U' )
459 ELSE IF(
lsame( uplo,
'L' ) )
THEN
460 idum1 = ichar( 'L' )
461 ELSE
462 info = -1
463 END IF
464
465 IF( lwork.LT.-1 ) THEN
466 info = -14
467 ELSE IF( lwork.EQ.-1 ) THEN
468 idum3 = -1
469 ELSE
470 idum3 = 1
471 END IF
472
473 IF( n.LT.0 ) THEN
474 info = -2
475 END IF
476
477 IF( n+ja-1.GT.store_n_a ) THEN
478 info = -( 7*100+6 )
479 END IF
480
481 IF( ( bw.GT.n-1 ) .OR. ( bw.LT.0 ) ) THEN
482 info = -3
483 END IF
484
485 IF( llda.LT.( bw+1 ) ) THEN
486 info = -( 7*100+6 )
487 END IF
488
489 IF( nb.LE.0 ) THEN
490 info = -( 7*100+4 )
491 END IF
492
493 IF( n+ib-1.GT.store_m_b ) THEN
494 info = -( 10*100+3 )
495 END IF
496
497 IF( lldb.LT.nb ) THEN
498 info = -( 10*100+6 )
499 END IF
500
501 IF( nrhs.LT.0 ) THEN
502 info = -3
503 END IF
504
505
506
507 IF( ja.NE.ib ) THEN
508 info = -6
509 END IF
510
511
512
513 IF( nprow.NE.1 ) THEN
514 info = -( 7*100+2 )
515 END IF
516
517 IF( n.GT.np*nb-mod( ja-1, nb ) ) THEN
518 info = -( 2 )
519 CALL pxerbla( ictxt,
'PSPBTRS, D&C alg.: only 1 block per proc'
520 $ , -info )
521 RETURN
522 END IF
523
524 IF( ( ja+n-1.GT.nb ) .AND. ( nb.LT.2*bw ) ) THEN
525 info = -( 7*100+4 )
526 CALL pxerbla( ictxt,
'PSPBTRS, D&C alg.: NB too small', -info )
527 RETURN
528 END IF
529
530
531 work_size_min = ( bw*nrhs )
532
533 work( 1 ) = work_size_min
534
535 IF( lwork.LT.work_size_min ) THEN
536 IF( lwork.NE.-1 ) THEN
537 info = -14
538 CALL pxerbla( ictxt,
'PSPBTRS: worksize error', -info )
539 END IF
540 RETURN
541 END IF
542
543
544
545 param_check( 16, 1 ) = descb( 5 )
546 param_check( 15, 1 ) = descb( 4 )
547 param_check( 14, 1 ) = descb( 3 )
548 param_check( 13, 1 ) = descb( 2 )
549 param_check( 12, 1 ) = descb( 1 )
550 param_check( 11, 1 ) = ib
551 param_check( 10, 1 ) = desca( 5 )
552 param_check( 9, 1 ) = desca( 4 )
553 param_check( 8, 1 ) = desca( 3 )
554 param_check( 7, 1 ) = desca( 1 )
555 param_check( 6, 1 ) = ja
556 param_check( 5, 1 ) = nrhs
557 param_check( 4, 1 ) = bw
558 param_check( 3, 1 ) = n
559 param_check( 2, 1 ) = idum3
560 param_check( 1, 1 ) = idum1
561
562 param_check( 16, 2 ) = 1005
563 param_check( 15, 2 ) = 1004
564 param_check( 14, 2 ) = 1003
565 param_check( 13, 2 ) = 1002
566 param_check( 12, 2 ) = 1001
567 param_check( 11, 2 ) = 9
568 param_check( 10, 2 ) = 705
569 param_check( 9, 2 ) = 704
570 param_check( 8, 2 ) = 703
571 param_check( 7, 2 ) = 701
572 param_check( 6, 2 ) = 6
573 param_check( 5, 2 ) = 4
574 param_check( 4, 2 ) = 3
575 param_check( 3, 2 ) = 2
576 param_check( 2, 2 ) = 14
577 param_check( 1, 2 ) = 1
578
579
580
581
582
583 IF( info.GE.0 ) THEN
584 info = bignum
585 ELSE IF( info.LT.-descmult ) THEN
586 info = -info
587 ELSE
588 info = -info*descmult
589 END IF
590
591
592
593 CALL globchk( ictxt, 16, param_check, 16, param_check( 1, 3 ),
594 $ info )
595
596
597
598
599 IF( info.EQ.bignum ) THEN
600 info = 0
601 ELSE IF( mod( info, descmult ).EQ.0 ) THEN
602 info = -info / descmult
603 ELSE
604 info = -info
605 END IF
606
607 IF( info.LT.0 ) THEN
608 CALL pxerbla( ictxt,
'PSPBTRS', -info )
609 RETURN
610 END IF
611
612
613
614 IF( n.EQ.0 )
615 $ RETURN
616
617 IF( nrhs.EQ.0 )
618 $ RETURN
619
620
621
622
623
624 part_offset = nb*( ( ja-1 ) / ( npcol*nb ) )
625
626 IF( ( mycol-csrc ).LT.( ja-part_offset-1 ) / nb ) THEN
627 part_offset = part_offset + nb
628 END IF
629
630 IF( mycol.LT.csrc ) THEN
631 part_offset = part_offset - nb
632 END IF
633
634
635
636
637
638
639
640 first_proc = mod( ( ja-1 ) / nb+csrc, npcol )
641
642
643
644 ja_new = mod( ja-1, nb ) + 1
645
646
647
648 np_save = np
649 np = ( ja_new+n-2 ) / nb + 1
650
651
652
653 CALL reshape( ictxt, int_one, ictxt_new, int_one, first_proc,
654 $ int_one, np )
655
656
657
658 ictxt_save = ictxt
659 ictxt = ictxt_new
660 desca_1xp( 2 ) = ictxt_new
661 descb_px1( 2 ) = ictxt_new
662
663
664
665 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
666
667
668
669 IF( myrow.LT.0 ) THEN
670 GO TO 20
671 END IF
672
673
674
675
676
677 info = 0
678
679
680
681 IF(
lsame( uplo,
'L' ) )
THEN
682
683 CALL pspbtrsv(
'L',
'N', n, bw, nrhs, a( part_offset+1 ),
684 $ ja_new, desca_1xp, b, ib, descb_px1, af, laf,
685 $ work, lwork, info )
686
687 ELSE
688
689 CALL pspbtrsv(
'U',
'T', n, bw, nrhs, a( part_offset+1 ),
690 $ ja_new, desca_1xp, b, ib, descb_px1, af, laf,
691 $ work, lwork, info )
692
693 END IF
694
695
696
697 IF(
lsame( uplo,
'L' ) )
THEN
698
699 CALL pspbtrsv(
'L',
'T', n, bw, nrhs, a( part_offset+1 ),
700 $ ja_new, desca_1xp, b, ib, descb_px1, af, laf,
701 $ work, lwork, info )
702
703 ELSE
704
705 CALL pspbtrsv(
'U',
'N', n, bw, nrhs, a( part_offset+1 ),
706 $ ja_new, desca_1xp, b, ib, descb_px1, af, laf,
707 $ work, lwork, info )
708
709 END IF
710 10 CONTINUE
711
712
713
714
715 IF( ictxt_save.NE.ictxt_new ) THEN
716 CALL blacs_gridexit( ictxt_new )
717 END IF
718
719 20 CONTINUE
720
721
722
723 ictxt = ictxt_save
724 np = np_save
725
726
727
728 work( 1 ) = work_size_min
729
730
731 RETURN
732
733
734
subroutine desc_convert(desc_in, desc_out, info)
subroutine globchk(ictxt, n, x, ldx, iwork, info)
subroutine pspbtrsv(uplo, trans, n, bw, nrhs, a, ja, desca, b, ib, descb, af, laf, work, lwork, info)
subroutine pxerbla(ictxt, srname, info)
void reshape(Int *context_in, Int *major_in, Int *context_out, Int *major_out, Int *first_proc, Int *nprow_new, Int *npcol_new)