3
    4
    5
    6
    7
    8
    9
   10      CHARACTER          UPLO
   11      INTEGER            IA, IB, JA, JB, M, N
   12
   13
   14      INTEGER            DESCA( * ), DESCB( * )
   15      REAL               A( * ), B( * )
   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      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
  143     $                   LLD_, MB_, M_, NB_, N_, RSRC_
  144      parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
  145     $                     ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
  146     $                     rsrc_ = 7, csrc_ = 8, lld_ = 9 )
  147
  148
  149      INTEGER            I, IAA, IBB, IBLK, IN, ITMP, J, JAA, JBB,
  150     $                   JBLK, JN, JTMP
  151
  152
  154
  155
  156      LOGICAL            LSAME
  157      INTEGER            ICEIL
  159
  160
  162
  163
  164
  165      IF( m.EQ.0 .OR. n.EQ.0 )
  166     $   RETURN
  167
  168      in = 
min( 
iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
 
  169      jn = 
min( 
iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
 
  170
  171      IF( m.LE.( desca( mb_ ) - mod( ia-1, desca( mb_ ) ) ) .OR.
  172     $    n.LE.( desca( nb_ ) - mod( ja-1, desca( nb_ ) ) ) ) THEN
  173         CALL pslacp2( uplo, m, n, a, ia, ja, desca,
 
  174     $                 b, ib, jb, descb )
  175      ELSE
  176
  177         IF( 
lsame( uplo, 
'U' ) ) 
THEN 
  178            CALL pslacp2( uplo, in-ia+1, n, a, ia, ja, desca,
 
  179     $                    b, ib, jb, descb )
  180            DO 10 i = in+1, ia+m-1, desca( mb_ )
  181               itmp = i-ia
  182               iblk = 
min( desca( mb_ ), m-itmp )
 
  183               ibb = ib + itmp
  184               jbb = jb + itmp
  185               jaa = ja + itmp
  186               CALL pslacp2( uplo, iblk, n-itmp, a, i, jaa, desca,
 
  187     $                       b, ibb, jbb, descb )
  188   10       CONTINUE
  189         ELSE IF( 
lsame( uplo, 
'L' ) ) 
THEN 
  190            CALL pslacp2( uplo, m, jn-ja+1, a, ia, ja, desca,
 
  191     $                    b, ib, jb, descb )
  192            DO 20 j = jn+1, ja+n-1, desca( nb_ )
  193               jtmp = j-ja
  194               jblk = 
min( desca( nb_ ), n-jtmp )
 
  195               ibb = ib + jtmp
  196               jbb = jb + jtmp
  197               iaa = ia + jtmp
  198               CALL pslacp2( uplo, m-jtmp, jblk, a, iaa, j, desca,
 
  199     $                       b, ibb, jbb, descb )
  200   20       CONTINUE
  201         ELSE
  202            IF( m.LE.n ) THEN
  203               CALL pslacp2( uplo, in-ia+1, n, a, ia, ja, desca,
 
  204     $                       b, ib, jb, descb )
  205               DO 30 i = in+1, ia+m-1, desca( mb_ )
  206                  itmp = i-ia
  207                  iblk = 
min( desca( mb_ ), m-itmp )
 
  208                  ibb = ib+itmp
  209                  CALL pslacp2( uplo, iblk, n, a, i, ja, desca,
 
  210     $                          b, ibb, jb, descb )
  211   30          CONTINUE
  212            ELSE
  213               CALL pslacp2( uplo, m, jn-ja+1, a, ia, ja, desca,
 
  214     $                       b, ib, jb, descb )
  215               DO 40 j = jn+1, ja+n-1, desca( nb_ )
  216                  jtmp = j-ja
  217                  jblk = 
min( desca( nb_ ), n-jtmp )
 
  218                  jbb = jb+jtmp
  219                  CALL pslacp2( uplo, m, jblk, a, ia, j, desca,
 
  220     $                          b, ib, jbb, descb )
  221   40          CONTINUE
  222            END IF
  223         END IF
  224
  225      END IF
  226
  227      RETURN
  228
  229
  230
integer function iceil(inum, idenom)
 
subroutine pslacp2(uplo, m, n, a, ia, ja, desca, b, ib, jb, descb)