3
4
5
6
7
8
9
10
11
12 CHARACTER TRANS
13 INTEGER IB, INFO, JA, LAF, LWORK, N, NRHS
14
15
16 INTEGER DESCA( * ), DESCB( * )
17 COMPLEX*16 AF( * ), B( * ), D( * ), DL( * ), DU( * ),
18 $ WORK( * )
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
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384 DOUBLE PRECISION ONE, ZERO
385 parameter( one = 1.0d+0 )
386 parameter( zero = 0.0d+0 )
387 COMPLEX*16 CONE, CZERO
388 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
389 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
390 INTEGER INT_ONE
391 parameter( int_one = 1 )
392 INTEGER DESCMULT, BIGNUM
393 parameter(descmult = 100, bignum = descmult * descmult)
394 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
395 $ LLD_, MB_, M_, NB_, N_, RSRC_
396 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
397 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
398 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
399
400
401 INTEGER CSRC, FIRST_PROC, ICTXT, ICTXT_NEW, ICTXT_SAVE,
402 $ IDUM2, IDUM3, JA_NEW, LLDA, LLDB, MYCOL, MYROW,
403 $ MY_NUM_COLS, NB, NP, NPCOL, NPROW, NP_SAVE,
404 $ ODD_SIZE, PART_OFFSET, PART_SIZE,
405 $ RETURN_CODE, STORE_M_B, STORE_N_A, TEMP,
406 $ WORK_SIZE_MIN
407
408
409 INTEGER DESCA_1XP( 7 ), DESCB_PX1( 7 ),
410 $ PARAM_CHECK( 15, 3 )
411
412
415
416
417 LOGICAL LSAME
418 INTEGER NUMROC
419 COMPLEX*16 ZDOTC
421
422
423 INTRINSIC ichar,
min, mod
424
425
426
427
428
429 info = 0
430
431
432
433
434 desca_1xp( 1 ) = 501
435 descb_px1( 1 ) = 502
436
437 temp = desca( dtype_ )
438 IF( temp .EQ. 502 ) THEN
439
440 desca( dtype_ ) = 501
441 ENDIF
442
444
445 desca( dtype_ ) = temp
446
447 IF( return_code .NE. 0) THEN
448 info = -( 8*100 + 2 )
449 ENDIF
450
452
453 IF( return_code .NE. 0) THEN
454 info = -( 11*100 + 2 )
455 ENDIF
456
457
458
459
460 IF( desca_1xp( 2 ) .NE. descb_px1( 2 ) ) THEN
461 info = -( 11*100 + 2 )
462 ENDIF
463
464
465
466
467
468 IF( desca_1xp( 4 ) .NE. descb_px1( 4 ) ) THEN
469 info = -( 11*100 + 4 )
470 ENDIF
471
472
473
474 IF( desca_1xp( 5 ) .NE. descb_px1( 5 ) ) THEN
475 info = -( 11*100 + 5 )
476 ENDIF
477
478
479
480 ictxt = desca_1xp( 2 )
481 csrc = desca_1xp( 5 )
482 nb = desca_1xp( 4 )
483 llda = desca_1xp( 6 )
484 store_n_a = desca_1xp( 3 )
485 lldb = descb_px1( 6 )
486 store_m_b = descb_px1( 3 )
487
488
489
490
491 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
492 np = nprow * npcol
493
494
495
496 IF(
lsame( trans,
'N' ) )
THEN
497 idum2 = ichar( 'N' )
498 ELSE IF (
lsame( trans,
'C' ) )
THEN
499 idum2 = ichar( 'C' )
500 ELSE
501 info = -1
502 END IF
503
504 IF( lwork .LT. -1) THEN
505 info = -15
506 ELSE IF ( lwork .EQ. -1 ) THEN
507 idum3 = -1
508 ELSE
509 idum3 = 1
510 ENDIF
511
512 IF( n .LT. 0 ) THEN
513 info = -2
514 ENDIF
515
516 IF( n+ja-1 .GT. store_n_a ) THEN
517 info = -( 8*100 + 6 )
518 ENDIF
519
520 IF( n+ib-1 .GT. store_m_b ) THEN
521 info = -( 11*100 + 3 )
522 ENDIF
523
524 IF( lldb .LT. nb ) THEN
525 info = -( 11*100 + 6 )
526 ENDIF
527
528 IF( nrhs .LT. 0 ) THEN
529 info = -3
530 ENDIF
531
532
533
534 IF( ja .NE. ib) THEN
535 info = -7
536 ENDIF
537
538
539
540 IF( nprow .NE. 1 ) THEN
541 info = -( 8*100+2 )
542 ENDIF
543
544 IF( n .GT. np*nb-mod( ja-1, nb )) THEN
545 info = -( 2 )
547 $ 'PZDTTRS, D&C alg.: only 1 block per proc',
548 $ -info )
549 RETURN
550 ENDIF
551
552 IF((ja+n-1.GT.nb) .AND. ( nb.LT.2*int_one )) THEN
553 info = -( 8*100+4 )
555 $ 'PZDTTRS, D&C alg.: NB too small',
556 $ -info )
557 RETURN
558 ENDIF
559
560
561 work_size_min =
562 $ 10*npcol+4*nrhs
563
564 work( 1 ) = work_size_min
565
566 IF( lwork .LT. work_size_min ) THEN
567 IF( lwork .NE. -1 ) THEN
568 info = -15
570 $ 'PZDTTRS: worksize error',
571 $ -info )
572 ENDIF
573 RETURN
574 ENDIF
575
576
577
578 param_check( 15, 1 ) = descb(5)
579 param_check( 14, 1 ) = descb(4)
580 param_check( 13, 1 ) = descb(3)
581 param_check( 12, 1 ) = descb(2)
582 param_check( 11, 1 ) = descb(1)
583 param_check( 10, 1 ) = ib
584 param_check( 9, 1 ) = desca(5)
585 param_check( 8, 1 ) = desca(4)
586 param_check( 7, 1 ) = desca(3)
587 param_check( 6, 1 ) = desca(1)
588 param_check( 5, 1 ) = ja
589 param_check( 4, 1 ) = nrhs
590 param_check( 3, 1 ) = n
591 param_check( 2, 1 ) = idum3
592 param_check( 1, 1 ) = idum2
593
594 param_check( 15, 2 ) = 1105
595 param_check( 14, 2 ) = 1104
596 param_check( 13, 2 ) = 1103
597 param_check( 12, 2 ) = 1102
598 param_check( 11, 2 ) = 1101
599 param_check( 10, 2 ) = 10
600 param_check( 9, 2 ) = 805
601 param_check( 8, 2 ) = 804
602 param_check( 7, 2 ) = 803
603 param_check( 6, 2 ) = 801
604 param_check( 5, 2 ) = 7
605 param_check( 4, 2 ) = 3
606 param_check( 3, 2 ) = 2
607 param_check( 2, 2 ) = 15
608 param_check( 1, 2 ) = 1
609
610
611
612
613
614 IF( info.GE.0 ) THEN
615 info = bignum
616 ELSE IF( info.LT.-descmult ) THEN
617 info = -info
618 ELSE
619 info = -info * descmult
620 END IF
621
622
623
624 CALL globchk( ictxt, 15, param_check, 15,
625 $ param_check( 1, 3 ), info )
626
627
628
629
630 IF( info.EQ.bignum ) THEN
631 info = 0
632 ELSE IF( mod( info, descmult ) .EQ. 0 ) THEN
633 info = -info / descmult
634 ELSE
635 info = -info
636 END IF
637
638 IF( info.LT.0 ) THEN
639 CALL pxerbla( ictxt,
'PZDTTRS', -info )
640 RETURN
641 END IF
642
643
644
645 IF( n.EQ.0 )
646 $ RETURN
647
648 IF( nrhs.EQ.0 )
649 $ RETURN
650
651
652
653
654
655 part_offset = nb*( (ja-1)/(npcol*nb) )
656
657 IF ( (mycol-csrc) .LT. (ja-part_offset-1)/nb ) THEN
658 part_offset = part_offset + nb
659 ENDIF
660
661 IF ( mycol .LT. csrc ) THEN
662 part_offset = part_offset - nb
663 ENDIF
664
665
666
667
668
669
670
671 first_proc = mod( ( ja-1 )/nb+csrc, npcol )
672
673
674
675 ja_new = mod( ja-1, nb ) + 1
676
677
678
679 np_save = np
680 np = ( ja_new+n-2 )/nb + 1
681
682
683
684 CALL reshape( ictxt, int_one, ictxt_new, int_one,
685 $ first_proc, int_one, np )
686
687
688
689 ictxt_save = ictxt
690 ictxt = ictxt_new
691 desca_1xp( 2 ) = ictxt_new
692 descb_px1( 2 ) = ictxt_new
693
694
695
696 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
697
698
699
700 IF( myrow .LT. 0 ) THEN
701 GOTO 1234
702 ENDIF
703
704
705
706
707
708
709 part_size = nb
710
711
712
713 my_num_cols =
numroc( n, part_size, mycol, 0, npcol )
714
715
716
717 IF ( mycol .EQ. 0 ) THEN
718 part_offset = part_offset+mod( ja_new-1, part_size )
719 my_num_cols = my_num_cols - mod(ja_new-1, part_size )
720 ENDIF
721
722
723
724 odd_size = my_num_cols
725 IF ( mycol .LT. np-1 ) THEN
726 odd_size = odd_size - int_one
727 ENDIF
728
729
730
731
732
733 info = 0
734
735
736
737 IF(
lsame( trans,
'N' ) )
THEN
738
739 CALL pzdttrsv(
'L',
'N', n, nrhs, dl( part_offset+1 ),
740 $ d( part_offset+1 ), du( part_offset+1 ), ja_new,
741 $ desca_1xp, b, ib, descb_px1, af, laf, work,
742 $ lwork, info )
743
744 ELSE
745
746 CALL pzdttrsv(
'U',
'C', n, nrhs, dl( part_offset+1 ),
747 $ d( part_offset+1 ), du( part_offset+1 ), ja_new,
748 $ desca_1xp, b, ib, descb_px1, af, laf, work,
749 $ lwork, info )
750
751 ENDIF
752
753
754
755 IF(
lsame( trans,
'C' ) )
THEN
756
757 CALL pzdttrsv(
'L',
'C', n, nrhs, dl( part_offset+1 ),
758 $ d( part_offset+1 ), du( part_offset+1 ), ja_new,
759 $ desca_1xp, b, ib, descb_px1, af, laf, work,
760 $ lwork, info )
761
762 ELSE
763
764 CALL pzdttrsv(
'U',
'N', n, nrhs, dl( part_offset+1 ),
765 $ d( part_offset+1 ), du( part_offset+1 ), ja_new,
766 $ desca_1xp, b, ib, descb_px1, af, laf, work,
767 $ lwork, info )
768
769 ENDIF
770 1000 CONTINUE
771
772
773
774
775 IF( ictxt_save .NE. ictxt_new ) THEN
776 CALL blacs_gridexit( ictxt_new )
777 ENDIF
778
779 1234 CONTINUE
780
781
782
783 ictxt = ictxt_save
784 np = np_save
785
786
787
788 work( 1 ) = work_size_min
789
790
791 RETURN
792
793
794
subroutine desc_convert(desc_in, desc_out, info)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
subroutine globchk(ictxt, n, x, ldx, iwork, info)
subroutine pxerbla(ictxt, srname, info)
subroutine pzdttrsv(uplo, trans, n, nrhs, dl, d, du, ja, desca, b, ib, descb, af, laf, work, lwork, info)
void reshape(Int *context_in, Int *major_in, Int *context_out, Int *major_out, Int *first_proc, Int *nprow_new, Int *npcol_new)