LAPACK 3.3.1
Linear Algebra PACKage

slapmr.f

Go to the documentation of this file.
00001       SUBROUTINE SLAPMR( FORWRD, M, N, X, LDX, K )
00002       IMPLICIT NONE
00003 *
00004 *     Originally SLAPMT
00005 *  -- LAPACK auxiliary routine (version 3.2) --
00006 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00007 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00008 *     November 2006
00009 *
00010 *     Adapted to SLAPMR
00011 *     July 2010
00012 *
00013 *     .. Scalar Arguments ..
00014       LOGICAL            FORWRD
00015       INTEGER            LDX, M, N
00016 *     ..
00017 *     .. Array Arguments ..
00018       INTEGER            K( * )
00019       REAL               X( LDX, * )
00020 *     ..
00021 *
00022 *  Purpose
00023 *  =======
00024 *
00025 *  SLAPMR rearranges the rows of the M by N matrix X as specified
00026 *  by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.
00027 *  If FORWRD = .TRUE.,  forward permutation:
00028 *
00029 *       X(K(I),*) is moved X(I,*) for I = 1,2,...,M.
00030 *
00031 *  If FORWRD = .FALSE., backward permutation:
00032 *
00033 *       X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.
00034 *
00035 *  Arguments
00036 *  =========
00037 *
00038 *  FORWRD  (input) LOGICAL
00039 *          = .TRUE., forward permutation
00040 *          = .FALSE., backward permutation
00041 *
00042 *  M       (input) INTEGER
00043 *          The number of rows of the matrix X. M >= 0.
00044 *
00045 *  N       (input) INTEGER
00046 *          The number of columns of the matrix X. N >= 0.
00047 *
00048 *  X       (input/output) REAL array, dimension (LDX,N)
00049 *          On entry, the M by N matrix X.
00050 *          On exit, X contains the permuted matrix X.
00051 *
00052 *  LDX     (input) INTEGER
00053 *          The leading dimension of the array X, LDX >= MAX(1,M).
00054 *
00055 *  K       (input/output) INTEGER array, dimension (M)
00056 *          On entry, K contains the permutation vector. K is used as
00057 *          internal workspace, but reset to its original value on
00058 *          output.
00059 *
00060 *  =====================================================================
00061 *
00062 *     .. Local Scalars ..
00063       INTEGER            I, IN, J, JJ
00064       REAL               TEMP
00065 *     ..
00066 *     .. Executable Statements ..
00067 *
00068       IF( M.LE.1 )
00069      $   RETURN
00070 *
00071       DO 10 I = 1, M
00072          K( I ) = -K( I )
00073    10 CONTINUE
00074 *
00075       IF( FORWRD ) THEN
00076 *
00077 *        Forward permutation
00078 *
00079          DO 50 I = 1, M
00080 *
00081             IF( K( I ).GT.0 )
00082      $         GO TO 40
00083 *
00084             J = I
00085             K( J ) = -K( J )
00086             IN = K( J )
00087 *
00088    20       CONTINUE
00089             IF( K( IN ).GT.0 )
00090      $         GO TO 40
00091 *
00092             DO 30 JJ = 1, N
00093                TEMP = X( J, JJ )
00094                X( J, JJ ) = X( IN, JJ )
00095                X( IN, JJ ) = TEMP
00096    30       CONTINUE
00097 *
00098             K( IN ) = -K( IN )
00099             J = IN
00100             IN = K( IN )
00101             GO TO 20
00102 *
00103    40       CONTINUE
00104 *
00105    50    CONTINUE
00106 *
00107       ELSE
00108 *
00109 *        Backward permutation
00110 *
00111          DO 90 I = 1, M
00112 *
00113             IF( K( I ).GT.0 )
00114      $         GO TO 80
00115 *
00116             K( I ) = -K( I )
00117             J = K( I )
00118    60       CONTINUE
00119             IF( J.EQ.I )
00120      $         GO TO 80
00121 *
00122             DO 70 JJ = 1, N
00123                TEMP = X( I, JJ )
00124                X( I, JJ ) = X( J, JJ )
00125                X( J, JJ ) = TEMP
00126    70       CONTINUE
00127 *
00128             K( J ) = -K( J )
00129             J = K( J )
00130             GO TO 60
00131 *
00132    80       CONTINUE
00133 *
00134    90    CONTINUE
00135 *
00136       END IF
00137 *
00138       RETURN
00139 *
00140 *     End of ZLAPMT
00141 *
00142       END
00143 
 All Files Functions