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

◆ pb_pslaprn2()

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

Definition at line 8848 of file psblastst.f.

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