1      SUBROUTINE pddbtrs( TRANS, N, BWL, BWU, NRHS, A, JA, DESCA, B, IB,
 
    2     $                    DESCB, AF, LAF, WORK, LWORK, INFO )
 
   11      INTEGER            BWL, BWU, IB, INFO, JA, LAF, LWORK, N, NRHS
 
   14      INTEGER            DESCA( * ), DESCB( * )
 
   15      DOUBLE PRECISION   A( * ), AF( * ), B( * ), WORK( * )
 
  367      parameter( int_one = 1 )
 
  368      INTEGER            DESCMULT, BIGNUM
 
  369      parameter( descmult = 100, bignum = descmult*descmult )
 
  370      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
 
  371     $                   lld_, mb_, m_, nb_, n_, rsrc_
 
  372      parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
 
  373     $                     ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
 
  374     $                     rsrc_ = 7, csrc_ = 8, lld_ = 9 )
 
  377      INTEGER            CSRC, FIRST_PROC, ICTXT, ICTXT_NEW, ICTXT_SAVE,
 
  378     $                   idum2, idum3, ja_new, llda, lldb, mycol, myrow,
 
  379     $                   nb, np, npcol, nprow, np_save, part_offset,
 
  380     $                   return_code, store_m_b, store_n_a,
 
  384      INTEGER            DESCA_1XP( 7 ), DESCB_PX1( 7 ),
 
  385     $                   param_check( 17, 3 )
 
  396      INTRINSIC          ichar, 
max, mod
 
  412      IF( return_code.NE.0 ) 
THEN 
  418      IF( return_code.NE.0 ) 
THEN 
  425      IF( desca_1xp( 2 ).NE.descb_px1( 2 ) ) 
THEN 
  433      IF( desca_1xp( 4 ).NE.descb_px1( 4 ) ) 
THEN 
  439      IF( desca_1xp( 5 ).NE.descb_px1( 5 ) ) 
THEN 
  445      ictxt = desca_1xp( 2 )
 
  446      csrc = desca_1xp( 5 )
 
  448      llda = desca_1xp( 6 )
 
  449      store_n_a = desca_1xp( 3 )
 
  450      lldb = descb_px1( 6 )
 
  451      store_m_b = descb_px1( 3 )
 
  456      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
 
  461      IF( lsame( trans, 
'N' ) ) 
THEN 
  463      ELSE IF( lsame( trans, 
'T' ) ) 
THEN 
  465      ELSE IF( lsame( trans, 
'C' ) ) 
THEN 
  471      IF( lwork.LT.-1 ) 
THEN 
  473      ELSE IF( lwork.EQ.-1 ) 
THEN 
  483      IF( n+ja-1.GT.store_n_a ) 
THEN 
  487      IF( ( bwl.GT.n-1 ) .OR. ( bwl.LT.0 ) ) 
THEN 
  491      IF( ( bwu.GT.n-1 ) .OR. ( bwu.LT.0 ) ) 
THEN 
  495      IF( llda.LT.( bwl+bwu+1 ) ) 
THEN 
  503      IF( n+ib-1.GT.store_m_b ) 
THEN 
  507      IF( lldb.LT.nb ) 
THEN 
  523      IF( nprow.NE.1 ) 
THEN 
  527      IF( n.GT.np*nb-mod( ja-1, nb ) ) 
THEN 
  529         CALL pxerbla( ictxt, 
'PDDBTRS, D&C alg.: only 1 block per proc' 
  534      IF( ( ja+n-1.GT.nb ) .AND. ( nb.LT.2*
max( bwl, bwu ) ) ) 
THEN 
  536         CALL pxerbla( ictxt, 
'PDDBTRS, D&C alg.: NB too small', -info )
 
  541      work_size_min = ( 
max( bwl, bwu )*nrhs )
 
  543      work( 1 ) = work_size_min
 
  545      IF( lwork.LT.work_size_min ) 
THEN 
  546         IF( lwork.NE.-1 ) 
THEN 
  548            CALL pxerbla( ictxt, 
'PDDBTRS: worksize error', -info )
 
  555      param_check( 17, 1 ) = descb( 5 )
 
  556      param_check( 16, 1 ) = descb( 4 )
 
  557      param_check( 15, 1 ) = descb( 3 )
 
  558      param_check( 14, 1 ) = descb( 2 )
 
  559      param_check( 13, 1 ) = descb( 1 )
 
  560      param_check( 12, 1 ) = ib
 
  561      param_check( 11, 1 ) = desca( 5 )
 
  562      param_check( 10, 1 ) = desca( 4 )
 
  563      param_check( 9, 1 ) = desca( 3 )
 
  564      param_check( 8, 1 ) = desca( 1 )
 
  565      param_check( 7, 1 ) = ja
 
  566      param_check( 6, 1 ) = nrhs
 
  567      param_check( 5, 1 ) = bwu
 
  568      param_check( 4, 1 ) = bwl
 
  569      param_check( 3, 1 ) = n
 
  570      param_check( 2, 1 ) = idum3
 
  571      param_check( 1, 1 ) = idum2
 
  573      param_check( 17, 2 ) = 1105
 
  574      param_check( 16, 2 ) = 1104
 
  575      param_check( 15, 2 ) = 1103
 
  576      param_check( 14, 2 ) = 1102
 
  577      param_check( 13, 2 ) = 1101
 
  578      param_check( 12, 2 ) = 10
 
  579      param_check( 11, 2 ) = 805
 
  580      param_check( 10, 2 ) = 804
 
  581      param_check( 9, 2 ) = 803
 
  582      param_check( 8, 2 ) = 801
 
  583      param_check( 7, 2 ) = 7
 
  584      param_check( 6, 2 ) = 5
 
  585      param_check( 5, 2 ) = 4
 
  586      param_check( 4, 2 ) = 3
 
  587      param_check( 3, 2 ) = 2
 
  588      param_check( 2, 2 ) = 15
 
  589      param_check( 1, 2 ) = 1
 
  597      ELSE IF( info.LT.-descmult ) 
THEN 
  600         info = -info*descmult
 
  605      CALL globchk( ictxt, 17, param_check, 17, param_check( 1, 3 ),
 
  611      IF( info.EQ.bignum ) 
THEN 
  613      ELSE IF( mod( info, descmult ).EQ.0 ) 
THEN 
  614         info = -info / descmult
 
  620         CALL pxerbla( ictxt, 
'PDDBTRS', -info )
 
  636      part_offset = nb*( ( ja-1 ) / ( npcol*nb ) )
 
  638      IF( ( mycol-csrc ).LT.( ja-part_offset-1 ) / nb ) 
THEN 
  639         part_offset = part_offset + nb
 
  642      IF( mycol.LT.csrc ) 
THEN 
  643         part_offset = part_offset - nb
 
  652      first_proc = mod( ( ja-1 ) / nb+csrc, npcol )
 
  656      ja_new = mod( ja-1, nb ) + 1
 
  661      np = ( ja_new+n-2 ) / nb + 1
 
  665      CALL reshape( ictxt, int_one, ictxt_new, int_one, first_proc,
 
  672      desca_1xp( 2 ) = ictxt_new
 
  673      descb_px1( 2 ) = ictxt_new
 
  677      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
 
  681      IF( myrow.LT.0 ) 
THEN 
  693      IF( lsame( trans, 
'N' ) ) 
THEN 
  695         CALL pddbtrsv( 
'L', 
'N', n, bwl, bwu, nrhs, a( part_offset+1 ),
 
  696     $                  ja_new, desca_1xp, b, ib, descb_px1, af, laf,
 
  697     $                  work, lwork, info )
 
  701         CALL pddbtrsv( 
'U', 
'T', n, bwl, bwu, nrhs, a( part_offset+1 ),
 
  702     $                  ja_new, desca_1xp, b, ib, descb_px1, af, laf,
 
  703     $                  work, lwork, info )
 
  709      IF( ( lsame( trans, 
'C' ) ) .OR. ( lsame( trans, 
'T' ) ) ) 
THEN 
  711         CALL pddbtrsv( 
'L', 
'T', n, bwl, bwu, nrhs, a( part_offset+1 ),
 
  712     $                  ja_new, desca_1xp, b, ib, descb_px1, af, laf,
 
  713     $                  work, lwork, info )
 
  717         CALL pddbtrsv( 
'U', 
'N', n, bwl, bwu, nrhs, a( part_offset+1 ),
 
  718     $                  ja_new, desca_1xp, b, ib, descb_px1, af, laf,
 
  719     $                  work, lwork, info )
 
  727      IF( ictxt_save.NE.ictxt_new ) 
THEN 
  728         CALL blacs_gridexit( ictxt_new )
 
  740      work( 1 ) = work_size_min