SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ pb_pdlaprn2()

subroutine pb_pdlaprn2 ( integer  m,
integer  n,
double precision, dimension( * )  a,
integer  ia,
integer  ja,
integer, dimension( * )  desca,
integer  irprnt,
integer  icprnt,
character*(*)  cmatnm,
integer  nout,
integer  prow,
integer  pcol,
double precision, dimension( * )  work 
)

Definition at line 8846 of file pdblastst.f.

8848*
8849* -- PBLAS test routine (version 2.0) --
8850* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
8851* and University of California, Berkeley.
8852* April 1, 1998
8853*
8854* .. Scalar Arguments ..
8855 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW
8856* ..
8857* .. Array Arguments ..
8858 CHARACTER*(*) CMATNM
8859 INTEGER DESCA( * )
8860 DOUBLE PRECISION A( * ), WORK( * )
8861* ..
8862*
8863* .. Parameters ..
8864 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
8865 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
8866 $ RSRC_
8867 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
8868 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
8869 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
8870 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
8871* ..
8872* .. Local Scalars ..
8873 LOGICAL AISCOLREP, AISROWREP
8874 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
8875 $ ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
8876 $ LDA, LDW, MYCOL, MYROW, NPCOL, NPROW
8877* ..
8878* .. External Subroutines ..
8879 EXTERNAL blacs_barrier, blacs_gridinfo, dgerv2d,
8880 $ dgesd2d, pb_infog2l
8881* ..
8882* .. Intrinsic Functions ..
8883 INTRINSIC min
8884* ..
8885* .. Executable Statements ..
8886*
8887* Get grid parameters
8888*
8889 ictxt = desca( ctxt_ )
8890 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
8891 CALL pb_infog2l( ia, ja, desca, nprow, npcol, myrow, mycol,
8892 $ iia, jja, iarow, iacol )
8893 ii = iia
8894 jj = jja
8895 IF( desca( rsrc_ ).LT.0 ) THEN
8896 aisrowrep = .true.
8897 iarow = prow
8898 icurrow = prow
8899 ELSE
8900 aisrowrep = .false.
8901 icurrow = iarow
8902 END IF
8903 IF( desca( csrc_ ).LT.0 ) THEN
8904 aiscolrep = .true.
8905 iacol = pcol
8906 icurcol = pcol
8907 ELSE
8908 aiscolrep = .false.
8909 icurcol = iacol
8910 END IF
8911 lda = desca( lld_ )
8912 ldw = max( desca( imb_ ), desca( mb_ ) )
8913*
8914* Handle the first block of column separately
8915*
8916 jb = desca( inb_ ) - ja + 1
8917 IF( jb.LE.0 )
8918 $ jb = ( (-jb) / desca( nb_ ) + 1 ) * desca( nb_ ) + jb
8919 jb = min( jb, n )
8920 jn = ja+jb-1
8921 DO 60 h = 0, jb-1
8922 ib = desca( imb_ ) - ia + 1
8923 IF( ib.LE.0 )
8924 $ ib = ( (-ib) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
8925 ib = min( ib, m )
8926 in = ia+ib-1
8927 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
8928 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
8929 DO 10 k = 0, ib-1
8930 WRITE( nout, fmt = 9999 )
8931 $ cmatnm, ia+k, ja+h, a( ii+k+(jj+h-1)*lda )
8932 10 CONTINUE
8933 END IF
8934 ELSE
8935 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
8936 CALL dgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ), lda,
8937 $ irprnt, icprnt )
8938 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
8939 CALL dgerv2d( ictxt, ib, 1, work, ldw, icurrow, icurcol )
8940 DO 20 k = 1, ib
8941 WRITE( nout, fmt = 9999 )
8942 $ cmatnm, ia+k-1, ja+h, work( k )
8943 20 CONTINUE
8944 END IF
8945 END IF
8946 IF( myrow.EQ.icurrow )
8947 $ ii = ii + ib
8948 IF( .NOT.aisrowrep )
8949 $ icurrow = mod( icurrow+1, nprow )
8950 CALL blacs_barrier( ictxt, 'All' )
8951*
8952* Loop over remaining block of rows
8953*
8954 DO 50 i = in+1, ia+m-1, desca( mb_ )
8955 ib = min( desca( mb_ ), ia+m-i )
8956 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
8957 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
8958 DO 30 k = 0, ib-1
8959 WRITE( nout, fmt = 9999 )
8960 $ cmatnm, i+k, ja+h, a( ii+k+(jj+h-1)*lda )
8961 30 CONTINUE
8962 END IF
8963 ELSE
8964 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
8965 CALL dgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
8966 $ lda, irprnt, icprnt )
8967 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
8968 CALL dgerv2d( ictxt, ib, 1, work, ldw, icurrow,
8969 $ icurcol )
8970 DO 40 k = 1, ib
8971 WRITE( nout, fmt = 9999 )
8972 $ cmatnm, i+k-1, ja+h, work( k )
8973 40 CONTINUE
8974 END IF
8975 END IF
8976 IF( myrow.EQ.icurrow )
8977 $ ii = ii + ib
8978 IF( .NOT.aisrowrep )
8979 $ icurrow = mod( icurrow+1, nprow )
8980 CALL blacs_barrier( ictxt, 'All' )
8981 50 CONTINUE
8982*
8983 ii = iia
8984 icurrow = iarow
8985 60 CONTINUE
8986*
8987 IF( mycol.EQ.icurcol )
8988 $ jj = jj + jb
8989 IF( .NOT.aiscolrep )
8990 $ icurcol = mod( icurcol+1, npcol )
8991 CALL blacs_barrier( ictxt, 'All' )
8992*
8993* Loop over remaining column blocks
8994*
8995 DO 130 j = jn+1, ja+n-1, desca( nb_ )
8996 jb = min( desca( nb_ ), ja+n-j )
8997 DO 120 h = 0, jb-1
8998 ib = desca( imb_ )-ia+1
8999 IF( ib.LE.0 )
9000 $ ib = ( (-ib) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
9001 ib = min( ib, m )
9002 in = ia+ib-1
9003 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9004 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9005 DO 70 k = 0, ib-1
9006 WRITE( nout, fmt = 9999 )
9007 $ cmatnm, ia+k, j+h, a( ii+k+(jj+h-1)*lda )
9008 70 CONTINUE
9009 END IF
9010 ELSE
9011 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9012 CALL dgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
9013 $ lda, irprnt, icprnt )
9014 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9015 CALL dgerv2d( ictxt, ib, 1, work, ldw, icurrow,
9016 $ icurcol )
9017 DO 80 k = 1, ib
9018 WRITE( nout, fmt = 9999 )
9019 $ cmatnm, ia+k-1, j+h, work( k )
9020 80 CONTINUE
9021 END IF
9022 END IF
9023 IF( myrow.EQ.icurrow )
9024 $ ii = ii + ib
9025 icurrow = mod( icurrow+1, nprow )
9026 CALL blacs_barrier( ictxt, 'All' )
9027*
9028* Loop over remaining block of rows
9029*
9030 DO 110 i = in+1, ia+m-1, desca( mb_ )
9031 ib = min( desca( mb_ ), ia+m-i )
9032 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9033 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9034 DO 90 k = 0, ib-1
9035 WRITE( nout, fmt = 9999 )
9036 $ cmatnm, i+k, j+h, a( ii+k+(jj+h-1)*lda )
9037 90 CONTINUE
9038 END IF
9039 ELSE
9040 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9041 CALL dgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
9042 $ lda, irprnt, icprnt )
9043 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9044 CALL dgerv2d( ictxt, ib, 1, work, ldw, icurrow,
9045 $ icurcol )
9046 DO 100 k = 1, ib
9047 WRITE( nout, fmt = 9999 )
9048 $ cmatnm, i+k-1, j+h, work( k )
9049 100 CONTINUE
9050 END IF
9051 END IF
9052 IF( myrow.EQ.icurrow )
9053 $ ii = ii + ib
9054 IF( .NOT.aisrowrep )
9055 $ icurrow = mod( icurrow+1, nprow )
9056 CALL blacs_barrier( ictxt, 'All' )
9057 110 CONTINUE
9058*
9059 ii = iia
9060 icurrow = iarow
9061 120 CONTINUE
9062*
9063 IF( mycol.EQ.icurcol )
9064 $ jj = jj + jb
9065 IF( .NOT.aiscolrep )
9066 $ icurcol = mod( icurcol+1, npcol )
9067 CALL blacs_barrier( ictxt, 'All' )
9068*
9069 130 CONTINUE
9070*
9071 9999 FORMAT( 1x, a, '(', i6, ',', i6, ')=', d30.18 )
9072*
9073 RETURN
9074*
9075* End of PB_PDLAPRN2
9076*
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
Here is the call graph for this function: