1 SUBROUTINE pddttrs( TRANS, N, NRHS, DL, D, DU, JA, DESCA, B, IB,
2 $ DESCB, AF, LAF, WORK, LWORK, INFO )
11 INTEGER IB, INFO, JA, LAF, LWORK, N, NRHS
14 INTEGER DESCA( * ), DESCB( * )
15 DOUBLE PRECISION AF( * ), B( * ), D( * ), DL( * ), DU( * ),
381 parameter( int_one = 1 )
382 INTEGER DESCMULT, BIGNUM
383 parameter( descmult = 100, bignum = descmult*descmult )
384 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
385 $ lld_, mb_, m_, nb_, n_, rsrc_
386 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
387 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
388 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
391 INTEGER CSRC, FIRST_PROC, ICTXT, ICTXT_NEW, ICTXT_SAVE,
392 $ idum2, idum3, ja_new, llda, lldb, mycol, myrow,
393 $ my_num_cols, nb, np, npcol, nprow, np_save,
394 $ odd_size, part_offset, part_size, return_code,
395 $ store_m_b, store_n_a, temp, work_size_min
398 INTEGER DESCA_1XP( 7 ), DESCB_PX1( 7 ),
399 $ param_check( 15, 3 )
408 EXTERNAL lsame, numroc
425 temp = desca( dtype_ )
426 IF( temp.EQ.502 )
THEN
428 desca( dtype_ ) = 501
433 desca( dtype_ ) = temp
435 IF( return_code.NE.0 )
THEN
441 IF( return_code.NE.0 )
THEN
448 IF( desca_1xp( 2 ).NE.descb_px1( 2 ) )
THEN
456 IF( desca_1xp( 4 ).NE.descb_px1( 4 ) )
THEN
462 IF( desca_1xp( 5 ).NE.descb_px1( 5 ) )
THEN
468 ictxt = desca_1xp( 2 )
469 csrc = desca_1xp( 5 )
471 llda = desca_1xp( 6 )
472 store_n_a = desca_1xp( 3 )
473 lldb = descb_px1( 6 )
474 store_m_b = descb_px1( 3 )
479 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
484 IF( lsame( trans,
'N' ) )
THEN
486 ELSE IF( lsame( trans,
'T' ) )
THEN
488 ELSE IF( lsame( trans,
'C' ) )
THEN
494 IF( lwork.LT.-1 )
THEN
496 ELSE IF( lwork.EQ.-1 )
THEN
506 IF( n+ja-1.GT.store_n_a )
THEN
510 IF( n+ib-1.GT.store_m_b )
THEN
514 IF( lldb.LT.nb )
THEN
530 IF( nprow.NE.1 )
THEN
534 IF( n.GT.np*nb-mod( ja-1, nb ) )
THEN
536 CALL pxerbla( ictxt,
'PDDTTRS, D&C alg.: only 1 block per proc'
541 IF( ( ja+n-1.GT.nb ) .AND. ( nb.LT.2*int_one ) )
THEN
543 CALL pxerbla( ictxt,
'PDDTTRS, D&C alg.: NB too small', -info )
548 work_size_min = 10*npcol + 4*nrhs
550 work( 1 ) = work_size_min
552 IF( lwork.LT.work_size_min )
THEN
553 IF( lwork.NE.-1 )
THEN
555 CALL pxerbla( ictxt,
'PDDTTRS: worksize error', -info )
562 param_check( 15, 1 ) = descb( 5 )
563 param_check( 14, 1 ) = descb( 4 )
564 param_check( 13, 1 ) = descb( 3 )
565 param_check( 12, 1 ) = descb( 2 )
566 param_check( 11, 1 ) = descb( 1 )
567 param_check( 10, 1 ) = ib
568 param_check( 9, 1 ) = desca( 5 )
569 param_check( 8, 1 ) = desca( 4 )
570 param_check( 7, 1 ) = desca( 3 )
571 param_check( 6, 1 ) = desca( 1 )
572 param_check( 5, 1 ) = ja
573 param_check( 4, 1 ) = nrhs
574 param_check( 3, 1 ) = n
575 param_check( 2, 1 ) = idum3
576 param_check( 1, 1 ) = idum2
578 param_check( 15, 2 ) = 1105
579 param_check( 14, 2 ) = 1104
580 param_check( 13, 2 ) = 1103
581 param_check( 12, 2 ) = 1102
582 param_check( 11, 2 ) = 1101
583 param_check( 10, 2 ) = 10
584 param_check( 9, 2 ) = 805
585 param_check( 8, 2 ) = 804
586 param_check( 7, 2 ) = 803
587 param_check( 6, 2 ) = 801
588 param_check( 5, 2 ) = 7
589 param_check( 4, 2 ) = 3
590 param_check( 3, 2 ) = 2
591 param_check( 2, 2 ) = 15
592 param_check( 1, 2 ) = 1
600 ELSE IF( info.LT.-descmult )
THEN
603 info = -info*descmult
608 CALL globchk( ictxt, 15, param_check, 15, param_check( 1, 3 ),
614 IF( info.EQ.bignum )
THEN
616 ELSE IF( mod( info, descmult ).EQ.0 )
THEN
617 info = -info / descmult
623 CALL pxerbla( ictxt,
'PDDTTRS', -info )
639 part_offset = nb*( ( ja-1 ) / ( npcol*nb ) )
641 IF( ( mycol-csrc ).LT.( ja-part_offset-1 ) / nb )
THEN
642 part_offset = part_offset + nb
645 IF( mycol.LT.csrc )
THEN
646 part_offset = part_offset - nb
655 first_proc = mod( ( ja-1 ) / nb+csrc, npcol )
659 ja_new = mod( ja-1, nb ) + 1
664 np = ( ja_new+n-2 ) / nb + 1
668 CALL reshape( ictxt, int_one, ictxt_new, int_one, first_proc,
675 desca_1xp( 2 ) = ictxt_new
676 descb_px1( 2 ) = ictxt_new
680 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
684 IF( myrow.LT.0 )
THEN
697 my_num_cols = numroc( n, part_size, mycol, 0, npcol )
701 IF( mycol.EQ.0 )
THEN
702 part_offset = part_offset + mod( ja_new-1, part_size )
703 my_num_cols = my_num_cols - mod( ja_new-1, part_size )
708 odd_size = my_num_cols
709 IF( mycol.LT.np-1 )
THEN
710 odd_size = odd_size - int_one
721 IF( lsame( trans,
'N' ) )
THEN
723 CALL pddttrsv(
'L',
'N', n, nrhs, dl( part_offset+1 ),
724 $ d( part_offset+1 ), du( part_offset+1 ), ja_new,
725 $ desca_1xp, b, ib, descb_px1, af, laf, work,
730 CALL pddttrsv(
'U',
'T', n, nrhs, dl( part_offset+1 ),
731 $ d( part_offset+1 ), du( part_offset+1 ), ja_new,
732 $ desca_1xp, b, ib, descb_px1, af, laf, work,
739 IF( ( lsame( trans,
'C' ) ) .OR. ( lsame( trans,
'T' ) ) )
THEN
741 CALL pddttrsv(
'L',
'T', n, nrhs, dl( part_offset+1 ),
742 $ d( part_offset+1 ), du( part_offset+1 ), ja_new,
743 $ desca_1xp, b, ib, descb_px1, af, laf, work,
748 CALL pddttrsv(
'U',
'N', n, nrhs, dl( part_offset+1 ),
749 $ d( part_offset+1 ), du( part_offset+1 ), ja_new,
750 $ desca_1xp, b, ib, descb_px1, af, laf, work,
759 IF( ictxt_save.NE.ictxt_new )
THEN
760 CALL blacs_gridexit( ictxt_new )
772 work( 1 ) = work_size_min