d5/d1d/pchkxmat_8f_source.html

00001       SUBROUTINE PCHK1MAT( MA, MAPOS0, NA, NAPOS0, IA, JA, DESCA,
00002      $                     DESCAPOS0, NEXTRA, EX, EXPOS, INFO )
00003 *
00004 *  -- ScaLAPACK tools routine (version 1.7) --
00005 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00006 *     and University of California, Berkeley.
00007 *     May 1, 1997
00008 *
00009 *     .. Scalar Arguments ..
00010       INTEGER            DESCAPOS0, IA, INFO, JA, MA, MAPOS0, NA,
00011      $                   NAPOS0, NEXTRA
00012 *     ..
00013 *     .. Array Arguments ..
00014       INTEGER            DESCA( * ), EX( NEXTRA ), EXPOS( NEXTRA )
00015 *     ..
00016 *
00017 *  Purpose
00018 *  =======
00019 *
00020 *  PCHK1MAT checks that the values associated with one distributed
00021 *  matrix are consistant across the entire process grid.
00022 *
00023 *  Notes
00024 *  =====
00025 *
00026 *  This routine checks that all values are the same across the grid.
00027 *  It does no local checking; it is therefore legal to abuse the
00028 *  definitions of the non-descriptor arguments, i.e., if the routine
00029 *  you are checking does not possess a MA value, you may pass some
00030 *  other integer that must be global into this argument instead.
00031 *
00032 *  Arguments
00033 *  =========
00034 *
00035 *  MA      (global input) INTEGER
00036 *          The global number of matrix rows of A being operated on.
00037 *
00038 *  MAPOS0  (global input) INTEGER
00039 *          Where in the calling routine's parameter list MA appears.
00040 *
00041 *  NA      (global input) INTEGER
00042 *          The global number of matrix columns of A being operated on.
00043 *
00044 *  NAPOS0  (global input) INTEGER
00045 *          Where in the calling routine's parameter list NA appears.
00046 *
00047 *  IA      (global input) INTEGER
00048 *          The row index in the global array A indicating the first
00049 *          row of sub( A ).
00050 *
00051 *  JA      (global input) INTEGER
00052 *          The column index in the global array A indicating the
00053 *          first column of sub( A ).
00054 *
00055 *  DESCA   (global and local input) INTEGER array of dimension DLEN_.
00056 *          The array descriptor for the distributed matrix A.
00057 *
00058 *  DESCAPOS0 (global input) INTEGER
00059 *          Where in the calling routine's parameter list DESCA
00060 *          appears.  Note that we assume IA and JA are respectively 2
00061 *          and 1 entries behind DESCA.
00062 *
00063 *  NEXTRA  (global input) INTEGER
00064 *          The number of extra parameters (i.e., besides the ones
00065 *          above) to check.  NEXTRA <= LDW - 11.
00066 *
00067 *  EX      (local input) INTEGER array of dimension (NEXTRA)
00068 *          The values of these extra parameters
00069 *
00070 *  EXPOS   (local input) INTEGER array of dimension (NEXTRA)
00071 *          The parameter list positions of these extra values.
00072 *
00073 *  INFO    (local input/global output) INTEGER
00074 *          = 0:  successful exit
00075 *          < 0:  If the i-th argument is an array and the j-entry had
00076 *                an illegal value, then INFO = -(i*100+j), if the i-th
00077 *                argument is a scalar and had an illegal value, then
00078 *                INFO = -i.
00079 *
00080 *  =====================================================================
00081 *
00082 *     .. Parameters ..
00083       INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
00084      $                   LLD_, MB_, M_, NB_, N_, RSRC_
00085       PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
00086      $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
00087      $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
00088       INTEGER            BIGNUM, DESCMULT, LDW
00089       PARAMETER          ( DESCMULT = 100, BIGNUM = DESCMULT * DESCMULT,
00090      $                     LDW = 25 )
00091 *     ..
00092 *     .. Local Scalars ..
00093       INTEGER            DESCPOS, K
00094 *     ..
00095 *     .. Local Arrays ..
00096       INTEGER            IWORK( LDW, 2 ), IWORK2( LDW )
00097 *     ..
00098 *     .. External Subroutines ..
00099       EXTERNAL           GLOBCHK
00100 *     ..
00101 *     .. Executable Statements ..
00102 *
00103 *     Want to find errors with MIN( ), so if no error, set it to a big
00104 *     number. If there already is an error, multiply by the the
00105 *     descriptor multiplier.
00106 *
00107       IF( INFO.GE.0 ) THEN
00108          INFO = BIGNUM
00109       ELSE IF( INFO.LT.-DESCMULT ) THEN
00110          INFO = -INFO
00111       ELSE
00112          INFO = -INFO * DESCMULT
00113       END IF
00114 *
00115 *     Pack values and their positions in the parameter list, factoring
00116 *     in the descriptor multiplier
00117 *
00118       IWORK( 1, 1 ) = MA
00119       IWORK( 1, 2 ) = MAPOS0 * DESCMULT
00120       IWORK( 2, 1 ) = NA
00121       IWORK( 2, 2 ) = NAPOS0 * DESCMULT
00122       IWORK( 3, 1 ) = IA
00123       IWORK( 3, 2 ) = (DESCAPOS0-2) * DESCMULT
00124       IWORK( 4, 1 ) = JA
00125       IWORK( 4, 2 ) = (DESCAPOS0-1) * DESCMULT
00126       DESCPOS = DESCAPOS0 * DESCMULT
00127 *
00128       IWORK(  5, 1 ) = DESCA( DTYPE_ )
00129       IWORK(  5, 2 ) = DESCPOS + DTYPE_
00130       IWORK(  6, 1 ) = DESCA( M_ )
00131       IWORK(  6, 2 ) = DESCPOS + M_
00132       IWORK(  7, 1 ) = DESCA( N_ )
00133       IWORK(  7, 2 ) = DESCPOS + N_
00134       IWORK(  8, 1 ) = DESCA( MB_ )
00135       IWORK(  8, 2 ) = DESCPOS + MB_
00136       IWORK(  9, 1 ) = DESCA( NB_ )
00137       IWORK(  9, 2 ) = DESCPOS + NB_
00138       IWORK( 10, 1 ) = DESCA( RSRC_ )
00139       IWORK( 10, 2 ) = DESCPOS + RSRC_
00140       IWORK( 11, 1 ) = DESCA( CSRC_ )
00141       IWORK( 11, 2 ) = DESCPOS + CSRC_
00142 *
00143       IF( NEXTRA.GT.0 ) THEN
00144          DO 10 K = 1, NEXTRA
00145             IWORK( 11+K, 1 ) = EX( K )
00146             IWORK( 11+K, 2 ) = EXPOS( K )
00147    10    CONTINUE
00148       END IF
00149       K = 11 + NEXTRA
00150 *
00151 *     Get the smallest error detected anywhere (BIGNUM if no error)
00152 *
00153       CALL GLOBCHK( DESCA( CTXT_ ), K, IWORK, LDW, IWORK2, INFO )
00154 *
00155 *     Prepare output: set info = 0 if no error, and divide by DESCMULT if
00156 *     error is not in a descriptor entry
00157 *
00158       IF( INFO .EQ. BIGNUM ) THEN
00159          INFO = 0
00160       ELSE IF( MOD( INFO, DESCMULT ) .EQ. 0 ) THEN
00161          INFO = -INFO / DESCMULT
00162       ELSE
00163          INFO = -INFO
00164       END IF
00165 *
00166       RETURN
00167 *
00168 *     End of PCHK1MAT
00169 *
00170       END
00171 *
00172       SUBROUTINE PCHK2MAT( MA, MAPOS0, NA, NAPOS0, IA, JA, DESCA,
00173      $                     DESCAPOS0, MB, MBPOS0, NB, NBPOS0, IB, JB,
00174      $                     DESCB, DESCBPOS0, NEXTRA, EX, EXPOS, INFO )
00175 *
00176 *  -- ScaLAPACK tools routine (version 1.7) --
00177 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00178 *     and University of California, Berkeley.
00179 *     May 1, 1997
00180 *
00181 *     .. Scalar Arguments ..
00182       INTEGER            DESCAPOS0, DESCBPOS0, IA, IB, INFO, JA, JB, MA,
00183      $                   MAPOS0, MB, MBPOS0, NA, NAPOS0, NB, NBPOS0,
00184      $                   NEXTRA
00185 *     ..
00186 *     .. Array Arguments ..
00187       INTEGER            DESCA( * ), DESCB( 8 ), EX( NEXTRA ),
00188      $                   EXPOS( NEXTRA )
00189 *     ..
00190 *
00191 *  Purpose
00192 *  =======
00193 *
00194 *  PCHK2MAT checks that the values associated with two distributed
00195 *  matrices are consistant across the entire process grid.
00196 *
00197 *  Notes
00198 *  =====
00199 *
00200 *  This routine checks that all values are the same across the grid.
00201 *  It does no local checking; it is therefore legal to abuse the
00202 *  definitions of the non-descriptor arguments, i.e., if the routine
00203 *  you are checking does not possess a MA value, you may pass some
00204 *  other integer that must be global into this argument instead.
00205 *
00206 *  Arguments
00207 *  =========
00208 *
00209 *  MA      (global input) INTEGER
00210 *          The global number of matrix rows of A being operated on.
00211 *
00212 *  MAPOS0  (global input) INTEGER
00213 *          Where in the calling routine's parameter list MA appears.
00214 *
00215 *  NA      (global input) INTEGER
00216 *          The global number of matrix columns of A being operated on.
00217 *
00218 *  NAPOS0  (global input) INTEGER
00219 *          Where in the calling routine's parameter list NA appears.
00220 *
00221 *  IA      (global input) INTEGER
00222 *          The row index in the global array A indicating the first
00223 *          row of sub( A ).
00224 *
00225 *  JA      (global input) INTEGER
00226 *          The column index in the global array A indicating the
00227 *          first column of sub( A ).
00228 *
00229 *  DESCA   (global and local input) INTEGER array of dimension DLEN_.
00230 *          The array descriptor for the distributed matrix A.
00231 *
00232 *  DESCAPOS0 (global input) INTEGER
00233 *          Where in the calling routine's parameter list DESCA
00234 *          appears.  Note that we assume IA and JA are respectively 2
00235 *          and 1 entries behind DESCA.
00236 *
00237 *  MB      (global input) INTEGER
00238 *          The global number of matrix rows of B being operated on.
00239 *
00240 *  MBPOS0  (global input) INTEGER
00241 *          Where in the calling routine's parameter list MB appears.
00242 *
00243 *  NB      (global input) INTEGER
00244 *          The global number of matrix columns of B being operated on.
00245 *
00246 *  NBPOS0  (global input) INTEGER
00247 *          Where in the calling routine's parameter list NB appears.
00248 *
00249 *  IB      (global input) INTEGER
00250 *          The row index in the global array B indicating the first
00251 *          row of sub( B ).
00252 *
00253 *  JB      (global input) INTEGER
00254 *          The column index in the global array B indicating the
00255 *          first column of sub( B ).
00256 *
00257 *  DESCB   (global and local input) INTEGER array of dimension DLEN_.
00258 *          The array descriptor for the distributed matrix B.
00259 *
00260 *  DESCBPOS0 (global input) INTEGER
00261 *          Where in the calling routine's parameter list DESCB
00262 *          appears. Note that we assume IB and JB are respectively 2
00263 *          and 1 entries behind DESCB.
00264 *
00265 *  NEXTRA  (global input) INTEGER
00266 *          The number of extra parameters (i.e., besides the ones
00267 *          above) to check.  NEXTRA <= LDW - 22.
00268 *
00269 *  EX      (local input) INTEGER array of dimension (NEXTRA)
00270 *          The values of these extra parameters
00271 *
00272 *  EXPOS   (local input) INTEGER array of dimension (NEXTRA)
00273 *          The parameter list positions of these extra values.
00274 *
00275 *  INFO    (local input/global output) INTEGER
00276 *          = 0:  successful exit
00277 *          < 0:  If the i-th argument is an array and the j-entry had
00278 *                an illegal value, then INFO = -(i*100+j), if the i-th
00279 *                argument is a scalar and had an illegal value, then
00280 *                INFO = -i.
00281 *
00282 *  =====================================================================
00283 *
00284 *     .. Parameters ..
00285       INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
00286      $                   LLD_, MB_, M_, NB_, N_, RSRC_
00287       PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
00288      $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
00289      $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
00290       INTEGER            DESCMULT, BIGNUM, LDW
00291       PARAMETER          ( DESCMULT = 100, BIGNUM = DESCMULT * DESCMULT,
00292      $                     LDW = 35 )
00293 *     ..
00294 *     .. Local Scalars ..
00295       INTEGER            K, DESCPOS
00296 *     ..
00297 *     .. Local Arrays ..
00298       INTEGER            IWORK( LDW, 2 ), IWORK2( LDW )
00299 *     ..
00300 *     .. External Subroutines ..
00301       EXTERNAL           GLOBCHK
00302 *     ..
00303 *     .. Intrinsic Functions ..
00304       INTRINSIC          MOD
00305 *     ..
00306 *     .. Executable Statements ..
00307 *
00308 *     Want to find errors with MIN( ), so if no error, set it to a big
00309 *     number. If there already is an error, multiply by the the
00310 *     descriptor multiplier.
00311 *
00312       IF( INFO.GE.0 ) THEN
00313          INFO = BIGNUM
00314       ELSE IF( INFO.LT.-DESCMULT ) THEN
00315          INFO = -INFO
00316       ELSE
00317          INFO = -INFO * DESCMULT
00318       END IF
00319 *
00320 *     Pack values and their positions in the parameter list, factoring
00321 *     in the descriptor multiplier
00322 *
00323       IWORK( 1, 1 ) = MA
00324       IWORK( 1, 2 ) = MAPOS0 * DESCMULT
00325       IWORK( 2, 1 ) = NA
00326       IWORK( 2, 2 ) = NAPOS0 * DESCMULT
00327       IWORK( 3, 1 ) = IA
00328       IWORK( 3, 2 ) = (DESCAPOS0-2) * DESCMULT
00329       IWORK( 4, 1 ) = JA
00330       IWORK( 4, 2 ) = (DESCAPOS0-1) * DESCMULT
00331       DESCPOS = DESCAPOS0 * DESCMULT
00332 *
00333       IWORK(  5, 1 ) = DESCA( DTYPE_ )
00334       IWORK(  5, 2 ) = DESCPOS + DTYPE_
00335       IWORK(  6, 1 ) = DESCA( M_ )
00336       IWORK(  6, 2 ) = DESCPOS + M_
00337       IWORK(  7, 1 ) = DESCA( N_ )
00338       IWORK(  7, 2 ) = DESCPOS + N_
00339       IWORK(  8, 1 ) = DESCA( MB_ )
00340       IWORK(  8, 2 ) = DESCPOS + MB_
00341       IWORK(  9, 1 ) = DESCA( NB_ )
00342       IWORK(  9, 2 ) = DESCPOS + NB_
00343       IWORK( 10, 1 ) = DESCA( RSRC_ )
00344       IWORK( 10, 2 ) = DESCPOS + RSRC_
00345       IWORK( 11, 1 ) = DESCA( CSRC_ )
00346       IWORK( 11, 2 ) = DESCPOS + CSRC_
00347 *
00348       IWORK( 12, 1 ) = MB
00349       IWORK( 12, 2 ) = MBPOS0 * DESCMULT
00350       IWORK( 13, 1 ) = NB
00351       IWORK( 13, 2 ) = NBPOS0 * DESCMULT
00352       IWORK( 14, 1 ) = IB
00353       IWORK( 14, 2 ) = (DESCBPOS0-2) * DESCMULT
00354       IWORK( 15, 1 ) = JB
00355       IWORK( 15, 2 ) = (DESCBPOS0-1) * DESCMULT
00356       DESCPOS = DESCBPOS0 * DESCMULT
00357 *
00358       IWORK( 16, 1 ) = DESCB( DTYPE_ )
00359       IWORK( 16, 2 ) = DESCPOS + DTYPE_
00360       IWORK( 17, 1 ) = DESCB( M_ )
00361       IWORK( 17, 2 ) = DESCPOS + M_
00362       IWORK( 18, 1 ) = DESCB( N_ )
00363       IWORK( 18, 2 ) = DESCPOS + N_
00364       IWORK( 19, 1 ) = DESCB( MB_ )
00365       IWORK( 19, 2 ) = DESCPOS + MB_
00366       IWORK( 20, 1 ) = DESCB( NB_ )
00367       IWORK( 20, 2 ) = DESCPOS + NB_
00368       IWORK( 21, 1 ) = DESCB( RSRC_ )
00369       IWORK( 21, 2 ) = DESCPOS + RSRC_
00370       IWORK( 22, 1 ) = DESCB( CSRC_ )
00371       IWORK( 22, 2 ) = DESCPOS + CSRC_
00372 *
00373       IF( NEXTRA.GT.0 ) THEN
00374          DO 10 K = 1, NEXTRA
00375             IWORK( 22+K, 1 ) = EX( K )
00376             IWORK( 22+K, 2 ) = EXPOS( K )
00377    10    CONTINUE
00378       END IF
00379       K = 22 + NEXTRA
00380 *
00381 *     Get the smallest error detected anywhere (BIGNUM if no error)
00382 *
00383       CALL GLOBCHK( DESCA( CTXT_ ), K, IWORK, LDW, IWORK2, INFO )
00384 *
00385 *     Prepare output: set info = 0 if no error, and divide by DESCMULT
00386 *     if error is not in a descriptor entry.
00387 *
00388       IF( INFO.EQ.BIGNUM ) THEN
00389          INFO = 0
00390       ELSE IF( MOD( INFO, DESCMULT ) .EQ. 0 ) THEN
00391          INFO = -INFO / DESCMULT
00392       ELSE
00393          INFO = -INFO
00394       END IF
00395 *
00396       RETURN
00397 *
00398 *     End of PCHK2MAT
00399 *
00400       END
00401 *
00402       SUBROUTINE GLOBCHK( ICTXT, N, X, LDX, IWORK, INFO )
00403 *
00404 *  -- ScaLAPACK tools routine (version 1.7) --
00405 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00406 *     and University of California, Berkeley.
00407 *     May 1, 1997
00408 *
00409 *     .. Scalar Arguments ..
00410       INTEGER            ICTXT, INFO, LDX, N
00411 *     ..
00412 *     .. Array Arguments ..
00413       INTEGER            IWORK( N ), X( LDX, 2 )
00414 *     ..
00415 *
00416 *  Purpose
00417 *  =======
00418 *
00419 *  GLOBCHK checks that values in X(i,1) are the same on all processes
00420 *  in the process grid indicated by ICTXT.
00421 *
00422 *  Arguments
00423 *  =========
00424 *
00425 *  ICTXT   (global input) INTEGER
00426 *          The BLACS context handle indicating the context over which
00427 *          the values are to be the same.
00428 *
00429 *  N       (global input) INTEGER
00430 *          The number of values to be compared.
00431 *
00432 *  X       (local input) INTEGER array, dimension (N,2)
00433 *          The 1st column contains the values which should be the same
00434 *          on all processes.  The 2nd column indicates where in the
00435 *          calling routine's parameter list the corresponding value
00436 *          from column 1 came from.
00437 *
00438 *  LDX     (local input) INTEGER
00439 *          The leading dimension of the array X. LDX >= MAX(1,N).
00440 *
00441 *  IWORK   (local workspace) INTEGER array, dimension (N)
00442 *          Used to receive other processes' values for comparing with X.
00443 *
00444 *  INFO    (local input/global output) INTEGER
00445 *          On entry, the smallest error flag so far generated, or BIGNUM
00446 *          for no error. On exit:
00447 *          = BIGNUM : no error
00448 *          < 0: if INFO = -i*100, the i-th argument had an illegal
00449 *               value, or was different between processes.
00450 *
00451 *  =====================================================================
00452 *
00453 *     .. Local Scalars ..
00454       INTEGER            K, MYROW, MYCOL
00455 *     ..
00456 *     .. External Subroutines ..
00457       EXTERNAL           BLACS_GRIDINFO, IGAMN2D, IGEBR2D, IGEBS2D
00458 *     ..
00459 *     .. Intrinsic Functions ..
00460       INTRINSIC          MIN
00461 *     ..
00462 *     .. Executable Statements ..
00463 *
00464       CALL BLACS_GRIDINFO( ICTXT, IWORK, K, MYROW, MYCOL )
00465 *
00466       IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
00467          CALL IGEBS2D( ICTXT, 'All', ' ', N, 1, X, N )
00468       ELSE
00469          CALL IGEBR2D( ICTXT, 'All', ' ', N, 1, IWORK, N, 0, 0 )
00470          DO 10 K = 1, N
00471             IF( X( K, 1 ).NE.IWORK( K ) )
00472      $         INFO = MIN( INFO, X( K, 2 ) )
00473    10    CONTINUE
00474       END IF
00475 *
00476       CALL IGAMN2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, K, K, -1, -1, 0 )
00477 *
00478       RETURN
00479 *
00480 *     End GLOBCHK
00481 *
00482       END