Salvatore Filippone
15 years ago
parent
5ffbc8ca82
commit
7530cafc83
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,396 +0,0 @@
|
||||
C
|
||||
C Parallel Sparse BLAS version 2.2
|
||||
C (C) Copyright 2006/2007/2008
|
||||
C Salvatore Filippone University of Rome Tor Vergata
|
||||
C Alfredo Buttari University of Rome Tor Vergata
|
||||
C
|
||||
C Redistribution and use in source and binary forms, with or without
|
||||
C modification, are permitted provided that the following conditions
|
||||
C are met:
|
||||
C 1. Redistributions of source code must retain the above copyright
|
||||
C notice, this list of conditions and the following disclaimer.
|
||||
C 2. Redistributions in binary form must reproduce the above copyright
|
||||
C notice, this list of conditions, and the following disclaimer in the
|
||||
C documentation and/or other materials provided with the distribution.
|
||||
C 3. The name of the PSBLAS group or the names of its contributors may
|
||||
C not be used to endorse or promote products derived from this
|
||||
C software without specific written permission.
|
||||
C
|
||||
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
C POSSIBILITY OF SUCH DAMAGE.
|
||||
C
|
||||
C
|
||||
C
|
||||
C This file imported from ScaLAPACK.
|
||||
C
|
||||
C
|
||||
SUBROUTINE PDTREECOMB( ICTXT, SCOPE, N, MINE, RDEST0, CDEST0,
|
||||
$ SUBPTR )
|
||||
*
|
||||
* -- ScaLAPACK tools routine (version 1.0) --
|
||||
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
|
||||
* and University of California, Berkeley.
|
||||
* February 28, 1995
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER SCOPE
|
||||
INTEGER CDEST0, ICTXT, N, RDEST0
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION MINE( * )
|
||||
* ..
|
||||
* .. Subroutine Arguments ..
|
||||
EXTERNAL SUBPTR
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* == = ====
|
||||
*
|
||||
* PDTREECOMB does a 1-tree parallel combine operation on scalars,
|
||||
* using the subroutine indicated by SUBPTR to perform the required
|
||||
* computation.
|
||||
*
|
||||
* Arguments
|
||||
* == = ======
|
||||
*
|
||||
* ICTXT (global input) INTEGER
|
||||
* The BLACS context handle, indicating the global context of
|
||||
* the operation. The context itself is global.
|
||||
*
|
||||
* SCOPE (global input) CHARACTER
|
||||
* The scope of the operation: 'Rowwise', 'Columnwise', or
|
||||
* 'All'.
|
||||
*
|
||||
* N (global input) INTEGER
|
||||
* The number of elements in MINE. N = 1 for the norm-2
|
||||
* computation and 2 for the sum of square.
|
||||
*
|
||||
* MINE (local input/global output) DOUBLE PRECISION array of
|
||||
* dimension at least equal to N. The local data to use in the
|
||||
* combine.
|
||||
*
|
||||
* RDEST0 (global input) INTEGER
|
||||
* The process row to receive the answer. If RDEST0 = -1,
|
||||
* every process in the scope gets the answer.
|
||||
*
|
||||
* CDEST0 (global input) INTEGER
|
||||
* The process column to receive the answer. If CDEST0 = -1,
|
||||
* every process in the scope gets the answer.
|
||||
*
|
||||
* SUBPTR (local input) Pointer to the subroutine to call to perform
|
||||
* the required combine.
|
||||
*
|
||||
* == = ==================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
LOGICAL BCAST, RSCOPE, CSCOPE
|
||||
INTEGER CMSSG, DEST, DIST, HISDIST, I, IAM, MYCOL,
|
||||
$ MYROW, MYDIST, MYDIST2, NP, NPCOL, NPROW,
|
||||
$ RMSSG, TCDEST, TRDEST
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
DOUBLE PRECISION HIS( 2 )
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
#if !defined(SERIAL_MPI)
|
||||
EXTERNAL BLACS_GRIDINFO, DGEBR2D, DGEBS2D,
|
||||
$ DGERV2D, DGESD2D
|
||||
#endif
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL PSB_LSAME
|
||||
EXTERNAL PSB_LSAME
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* See if everyone wants the answer (need to broadcast the answer)
|
||||
*
|
||||
BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) )
|
||||
IF( BCAST ) THEN
|
||||
TRDEST = 0
|
||||
TCDEST = 0
|
||||
ELSE
|
||||
TRDEST = RDEST0
|
||||
TCDEST = CDEST0
|
||||
END IF
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
*
|
||||
* Get grid parameters.
|
||||
*
|
||||
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
|
||||
*
|
||||
* Figure scope-dependant variables, or report illegal scope
|
||||
*
|
||||
RSCOPE = PSB_LSAME( SCOPE, 'R' )
|
||||
CSCOPE = PSB_LSAME( SCOPE, 'C' )
|
||||
*
|
||||
IF( RSCOPE ) THEN
|
||||
IF( BCAST ) THEN
|
||||
TRDEST = MYROW
|
||||
ELSE IF( MYROW.NE.TRDEST ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
NP = NPCOL
|
||||
MYDIST = MOD( NPCOL + MYCOL - TCDEST, NPCOL )
|
||||
ELSE IF( CSCOPE ) THEN
|
||||
IF( BCAST ) THEN
|
||||
TCDEST = MYCOL
|
||||
ELSE IF( MYCOL.NE.TCDEST ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
NP = NPROW
|
||||
MYDIST = MOD( NPROW + MYROW - TRDEST, NPROW )
|
||||
ELSE IF( PSB_LSAME( SCOPE, 'A' ) ) THEN
|
||||
NP = NPROW * NPCOL
|
||||
IAM = MYROW*NPCOL + MYCOL
|
||||
DEST = TRDEST*NPCOL + TCDEST
|
||||
MYDIST = MOD( NP + IAM - DEST, NP )
|
||||
ELSE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( NP.LT.2 )
|
||||
$ RETURN
|
||||
*
|
||||
MYDIST2 = MYDIST
|
||||
RMSSG = MYROW
|
||||
CMSSG = MYCOL
|
||||
I = 1
|
||||
*
|
||||
10 CONTINUE
|
||||
*
|
||||
IF( MOD( MYDIST, 2 ).NE.0 ) THEN
|
||||
*
|
||||
* If I am process that sends information
|
||||
*
|
||||
DIST = I * ( MYDIST - MOD( MYDIST, 2 ) )
|
||||
*
|
||||
* Figure coordinates of dest of message
|
||||
*
|
||||
IF( RSCOPE ) THEN
|
||||
CMSSG = MOD( TCDEST + DIST, NP )
|
||||
ELSE IF( CSCOPE ) THEN
|
||||
RMSSG = MOD( TRDEST + DIST, NP )
|
||||
ELSE
|
||||
CMSSG = MOD( DEST + DIST, NP )
|
||||
RMSSG = CMSSG / NPCOL
|
||||
CMSSG = MOD( CMSSG, NPCOL )
|
||||
END IF
|
||||
*
|
||||
CALL DGESD2D( ICTXT, N, 1, MINE, N, RMSSG, CMSSG )
|
||||
*
|
||||
GO TO 20
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* If I am a process receiving information, figure coordinates
|
||||
* of source of message
|
||||
*
|
||||
DIST = MYDIST2 + I
|
||||
IF( RSCOPE ) THEN
|
||||
CMSSG = MOD( TCDEST + DIST, NP )
|
||||
HISDIST = MOD( NP + CMSSG - TCDEST, NP )
|
||||
ELSE IF( CSCOPE ) THEN
|
||||
RMSSG = MOD( TRDEST + DIST, NP )
|
||||
HISDIST = MOD( NP + RMSSG - TRDEST, NP )
|
||||
ELSE
|
||||
CMSSG = MOD( DEST + DIST, NP )
|
||||
RMSSG = CMSSG / NPCOL
|
||||
CMSSG = MOD( CMSSG, NPCOL )
|
||||
HISDIST = MOD( NP + RMSSG*NPCOL+CMSSG - DEST, NP )
|
||||
END IF
|
||||
*
|
||||
IF( MYDIST2.LT.HISDIST ) THEN
|
||||
*
|
||||
* If I have anyone sending to me
|
||||
*
|
||||
CALL DGERV2D( ICTXT, N, 1, HIS, N, RMSSG, CMSSG )
|
||||
CALL SUBPTR( MINE, HIS )
|
||||
*
|
||||
END IF
|
||||
MYDIST = MYDIST / 2
|
||||
*
|
||||
END IF
|
||||
I = I * 2
|
||||
*
|
||||
IF( I.LT.NP )
|
||||
$ GO TO 10
|
||||
*
|
||||
20 CONTINUE
|
||||
*
|
||||
IF( BCAST ) THEN
|
||||
IF( MYDIST2.EQ.0 ) THEN
|
||||
CALL DGEBS2D( ICTXT, SCOPE, ' ', N, 1, MINE, N )
|
||||
ELSE
|
||||
CALL DGEBR2D( ICTXT, SCOPE, ' ', N, 1, MINE, N,
|
||||
$ TRDEST, TCDEST )
|
||||
END IF
|
||||
END IF
|
||||
#endif
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of PDTREECOMB
|
||||
*
|
||||
END
|
||||
*
|
||||
SUBROUTINE DCOMBAMAX( V1, V2 )
|
||||
*
|
||||
* -- ScaLAPACK tools routine (version 1.0) --
|
||||
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
|
||||
* and University of California, Berkeley.
|
||||
* February 28, 1995
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION V1( 2 ), V2( 2 )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* == = ====
|
||||
*
|
||||
* DCOMBAMAX finds the element having max. absolute value as well
|
||||
* as its corresponding globl index.
|
||||
*
|
||||
* Arguments
|
||||
* == = ======
|
||||
*
|
||||
* V1 (local input/local output) DOUBLE PRECISION array of
|
||||
* dimension 2. The first maximum absolute value element and
|
||||
* its global index. V1(1) = AMAX, V1(2) = INDX.
|
||||
*
|
||||
* V2 (local input) DOUBLE PRECISION array of dimension 2.
|
||||
* The second maximum absolute value element and its global
|
||||
* index. V2(1) = AMAX, V2(2) = INDX.
|
||||
*
|
||||
* == = ==================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( ABS( V1( 1 ) ).LT.ABS( V2( 1 ) ) ) THEN
|
||||
V1( 1 ) = V2( 1 )
|
||||
V1( 2 ) = V2( 2 )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DCOMBAMAX
|
||||
*
|
||||
END
|
||||
*
|
||||
SUBROUTINE DCOMBSSQ( V1, V2 )
|
||||
*
|
||||
* -- ScaLAPACK tools routine (version 1.0) --
|
||||
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
|
||||
* and University of California, Berkeley.
|
||||
* February 28, 1995
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION V1( 2 ), V2( 2 )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* == = ====
|
||||
*
|
||||
* DCOMBSSQ does a scaled sum of squares on two scalars.
|
||||
*
|
||||
* Arguments
|
||||
* == = ======
|
||||
*
|
||||
* V1 (local input/local output) DOUBLE PRECISION array of
|
||||
* dimension 2. The first scaled sum. V1(1) = SCALE,
|
||||
* V1(2) = SUMSQ.
|
||||
*
|
||||
* V2 (local input) DOUBLE PRECISION array of dimension 2.
|
||||
* The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ.
|
||||
*
|
||||
* == = ==================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( V1( 1 ).GE.V2( 1 ) ) THEN
|
||||
IF( V1( 1 ).NE.ZERO )
|
||||
$ V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 )
|
||||
ELSE
|
||||
V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 )
|
||||
V1( 1 ) = V2( 1 )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DCOMBSSQ
|
||||
*
|
||||
END
|
||||
*
|
||||
SUBROUTINE DCOMBNRM2( X, Y )
|
||||
*
|
||||
* -- ScaLAPACK tools routine (version 1.0) --
|
||||
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
|
||||
* and University of California, Berkeley.
|
||||
* February 28, 1995
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION X, Y
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* == = ====
|
||||
*
|
||||
* DCOMBNRM2 combines local norm 2 results, taking care not to cause
|
||||
* unnecessary overflow.
|
||||
*
|
||||
* Arguments
|
||||
* == = ======
|
||||
*
|
||||
* X (local input) DOUBLE PRECISION
|
||||
* Y (local input) DOUBLE PRECISION
|
||||
* X and Y specify the values x and y. X and Y are supposed to
|
||||
* be >= 0.
|
||||
*
|
||||
* == = ==================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION W, Z
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
W = MAX( X, Y )
|
||||
Z = MIN( X, Y )
|
||||
*
|
||||
IF( Z.EQ.ZERO ) THEN
|
||||
X = W
|
||||
ELSE
|
||||
X = W*SQRT( ONE+( Z / W )**2 )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DCOMBNRM2
|
||||
*
|
||||
END
|
||||
@ -1,396 +0,0 @@
|
||||
C
|
||||
C Parallel Sparse BLAS version 2.2
|
||||
C (C) Copyright 2006/2007/2008
|
||||
C Salvatore Filippone University of Rome Tor Vergata
|
||||
C Alfredo Buttari University of Rome Tor Vergata
|
||||
C
|
||||
C Redistribution and use in source and binary forms, with or without
|
||||
C modification, are permitted provided that the following conditions
|
||||
C are met:
|
||||
C 1. Redistributions of source code must retain the above copyright
|
||||
C notice, this list of conditions and the following disclaimer.
|
||||
C 2. Redistributions in binary form must reproduce the above copyright
|
||||
C notice, this list of conditions, and the following disclaimer in the
|
||||
C documentation and/or other materials provided with the distribution.
|
||||
C 3. The name of the PSBLAS group or the names of its contributors may
|
||||
C not be used to endorse or promote products derived from this
|
||||
C software without specific written permission.
|
||||
C
|
||||
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
C POSSIBILITY OF SUCH DAMAGE.
|
||||
C
|
||||
C
|
||||
C
|
||||
C This file imported from ScaLAPACK.
|
||||
C
|
||||
C
|
||||
SUBROUTINE PSTREECOMB( ICTXT, SCOPE, N, MINE, RDEST0, CDEST0,
|
||||
$ SUBPTR )
|
||||
*
|
||||
* -- ScaLAPACK tools routine (version 1.5) --
|
||||
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
|
||||
* and University of California, Berkeley.
|
||||
* May 1, 1997
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER SCOPE
|
||||
INTEGER CDEST0, ICTXT, N, RDEST0
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL MINE( * )
|
||||
* ..
|
||||
* .. Subroutine Arguments ..
|
||||
EXTERNAL SUBPTR
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* == = ====
|
||||
*
|
||||
* PSTREECOMB does a 1-tree parallel combine operation on scalars,
|
||||
* using the subroutine indicated by SUBPTR to perform the required
|
||||
* computation.
|
||||
*
|
||||
* Arguments
|
||||
* == = ======
|
||||
*
|
||||
* ICTXT (global input) INTEGER
|
||||
* The BLACS context handle, indicating the global context of
|
||||
* the operation. The context itself is global.
|
||||
*
|
||||
* SCOPE (global input) CHARACTER
|
||||
* The scope of the operation: 'Rowwise', 'Columnwise', or
|
||||
* 'All'.
|
||||
*
|
||||
* N (global input) INTEGER
|
||||
* The number of elements in MINE. N = 1 for the norm-2
|
||||
* computation and 2 for the sum of square.
|
||||
*
|
||||
* MINE (local input/global output) REAL array of
|
||||
* dimension at least equal to N. The local data to use in the
|
||||
* combine.
|
||||
*
|
||||
* RDEST0 (global input) INTEGER
|
||||
* The process row to receive the answer. If RDEST0 = -1,
|
||||
* every process in the scope gets the answer.
|
||||
*
|
||||
* CDEST0 (global input) INTEGER
|
||||
* The process column to receive the answer. If CDEST0 = -1,
|
||||
* every process in the scope gets the answer.
|
||||
*
|
||||
* SUBPTR (local input) Pointer to the subroutine to call to perform
|
||||
* the required combine.
|
||||
*
|
||||
* == = ==================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
LOGICAL BCAST, RSCOPE, CSCOPE
|
||||
INTEGER CMSSG, DEST, DIST, HISDIST, I, IAM, MYCOL,
|
||||
$ MYROW, MYDIST, MYDIST2, NP, NPCOL, NPROW,
|
||||
$ RMSSG, TCDEST, TRDEST
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
REAL HIS( 2 )
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
#if !defined(SERIAL_MPI)
|
||||
EXTERNAL BLACS_GRIDINFO, SGEBR2D, SGEBS2D,
|
||||
$ SGERV2D, SGESD2D
|
||||
#endif
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL PSB_LSAME
|
||||
EXTERNAL PSB_LSAME
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* See if everyone wants the answer (need to broadcast the answer)
|
||||
*
|
||||
BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) )
|
||||
IF( BCAST ) THEN
|
||||
TRDEST = 0
|
||||
TCDEST = 0
|
||||
ELSE
|
||||
TRDEST = RDEST0
|
||||
TCDEST = CDEST0
|
||||
END IF
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
*
|
||||
* Get grid parameters.
|
||||
*
|
||||
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
|
||||
*
|
||||
* Figure scope-dependant variables, or report illegal scope
|
||||
*
|
||||
RSCOPE = PSB_LSAME( SCOPE, 'R' )
|
||||
CSCOPE = PSB_LSAME( SCOPE, 'C' )
|
||||
*
|
||||
IF( RSCOPE ) THEN
|
||||
IF( BCAST ) THEN
|
||||
TRDEST = MYROW
|
||||
ELSE IF( MYROW.NE.TRDEST ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
NP = NPCOL
|
||||
MYDIST = MOD( NPCOL + MYCOL - TCDEST, NPCOL )
|
||||
ELSE IF( CSCOPE ) THEN
|
||||
IF( BCAST ) THEN
|
||||
TCDEST = MYCOL
|
||||
ELSE IF( MYCOL.NE.TCDEST ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
NP = NPROW
|
||||
MYDIST = MOD( NPROW + MYROW - TRDEST, NPROW )
|
||||
ELSE IF( PSB_LSAME( SCOPE, 'A' ) ) THEN
|
||||
NP = NPROW * NPCOL
|
||||
IAM = MYROW*NPCOL + MYCOL
|
||||
DEST = TRDEST*NPCOL + TCDEST
|
||||
MYDIST = MOD( NP + IAM - DEST, NP )
|
||||
ELSE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( NP.LT.2 )
|
||||
$ RETURN
|
||||
*
|
||||
MYDIST2 = MYDIST
|
||||
RMSSG = MYROW
|
||||
CMSSG = MYCOL
|
||||
I = 1
|
||||
*
|
||||
10 CONTINUE
|
||||
*
|
||||
IF( MOD( MYDIST, 2 ).NE.0 ) THEN
|
||||
*
|
||||
* If I am process that sends information
|
||||
*
|
||||
DIST = I * ( MYDIST - MOD( MYDIST, 2 ) )
|
||||
*
|
||||
* Figure coordinates of dest of message
|
||||
*
|
||||
IF( RSCOPE ) THEN
|
||||
CMSSG = MOD( TCDEST + DIST, NP )
|
||||
ELSE IF( CSCOPE ) THEN
|
||||
RMSSG = MOD( TRDEST + DIST, NP )
|
||||
ELSE
|
||||
CMSSG = MOD( DEST + DIST, NP )
|
||||
RMSSG = CMSSG / NPCOL
|
||||
CMSSG = MOD( CMSSG, NPCOL )
|
||||
END IF
|
||||
*
|
||||
CALL SGESD2D( ICTXT, N, 1, MINE, N, RMSSG, CMSSG )
|
||||
*
|
||||
GO TO 20
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* If I am a process receiving information, figure coordinates
|
||||
* of source of message
|
||||
*
|
||||
DIST = MYDIST2 + I
|
||||
IF( RSCOPE ) THEN
|
||||
CMSSG = MOD( TCDEST + DIST, NP )
|
||||
HISDIST = MOD( NP + CMSSG - TCDEST, NP )
|
||||
ELSE IF( CSCOPE ) THEN
|
||||
RMSSG = MOD( TRDEST + DIST, NP )
|
||||
HISDIST = MOD( NP + RMSSG - TRDEST, NP )
|
||||
ELSE
|
||||
CMSSG = MOD( DEST + DIST, NP )
|
||||
RMSSG = CMSSG / NPCOL
|
||||
CMSSG = MOD( CMSSG, NPCOL )
|
||||
HISDIST = MOD( NP + RMSSG*NPCOL+CMSSG - DEST, NP )
|
||||
END IF
|
||||
*
|
||||
IF( MYDIST2.LT.HISDIST ) THEN
|
||||
*
|
||||
* If I have anyone sending to me
|
||||
*
|
||||
CALL SGERV2D( ICTXT, N, 1, HIS, N, RMSSG, CMSSG )
|
||||
CALL SUBPTR( MINE, HIS )
|
||||
*
|
||||
END IF
|
||||
MYDIST = MYDIST / 2
|
||||
*
|
||||
END IF
|
||||
I = I * 2
|
||||
*
|
||||
IF( I.LT.NP )
|
||||
$ GO TO 10
|
||||
*
|
||||
20 CONTINUE
|
||||
*
|
||||
IF( BCAST ) THEN
|
||||
IF( MYDIST2.EQ.0 ) THEN
|
||||
CALL SGEBS2D( ICTXT, SCOPE, ' ', N, 1, MINE, N )
|
||||
ELSE
|
||||
CALL SGEBR2D( ICTXT, SCOPE, ' ', N, 1, MINE, N,
|
||||
$ TRDEST, TCDEST )
|
||||
END IF
|
||||
END IF
|
||||
#endif
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of PSTREECOMB
|
||||
*
|
||||
END
|
||||
*
|
||||
SUBROUTINE SCOMBAMAX( V1, V2 )
|
||||
*
|
||||
* -- ScaLAPACK tools routine (version 1.5) --
|
||||
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
|
||||
* and University of California, Berkeley.
|
||||
* May 1, 1997
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
REAL V1( 2 ), V2( 2 )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* == = ====
|
||||
*
|
||||
* SCOMBAMAX finds the element having max. absolute value as well
|
||||
* as its corresponding globl index.
|
||||
*
|
||||
* Arguments
|
||||
* == = ======
|
||||
*
|
||||
* V1 (local input/local output) REAL array of
|
||||
* dimension 2. The first maximum absolute value element and
|
||||
* its global index. V1(1) = AMAX, V1(2) = INDX.
|
||||
*
|
||||
* V2 (local input) REAL array of dimension 2.
|
||||
* The second maximum absolute value element and its global
|
||||
* index. V2(1) = AMAX, V2(2) = INDX.
|
||||
*
|
||||
* == = ==================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( ABS( V1( 1 ) ).LT.ABS( V2( 1 ) ) ) THEN
|
||||
V1( 1 ) = V2( 1 )
|
||||
V1( 2 ) = V2( 2 )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SCOMBAMAX
|
||||
*
|
||||
END
|
||||
*
|
||||
SUBROUTINE SCOMBSSQ( V1, V2 )
|
||||
*
|
||||
* -- ScaLAPACK tools routine (version 1.5) --
|
||||
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
|
||||
* and University of California, Berkeley.
|
||||
* May 1, 1997
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
REAL V1( 2 ), V2( 2 )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* == = ====
|
||||
*
|
||||
* SCOMBSSQ does a scaled sum of squares on two scalars.
|
||||
*
|
||||
* Arguments
|
||||
* == = ======
|
||||
*
|
||||
* V1 (local input/local output) REAL array of
|
||||
* dimension 2. The first scaled sum. V1(1) = SCALE,
|
||||
* V1(2) = SUMSQ.
|
||||
*
|
||||
* V2 (local input) REAL array of dimension 2.
|
||||
* The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ.
|
||||
*
|
||||
* == = ==================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( V1( 1 ).GE.V2( 1 ) ) THEN
|
||||
IF( V1( 1 ).NE.ZERO )
|
||||
$ V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 )
|
||||
ELSE
|
||||
V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 )
|
||||
V1( 1 ) = V2( 1 )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SCOMBSSQ
|
||||
*
|
||||
END
|
||||
*
|
||||
SUBROUTINE SCOMBNRM2( X, Y )
|
||||
*
|
||||
* -- ScaLAPACK tools routine (version 1.5) --
|
||||
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
|
||||
* and University of California, Berkeley.
|
||||
* May 1, 1997
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL X, Y
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* == = ====
|
||||
*
|
||||
* SCOMBNRM2 combines local norm 2 results, taking care not to cause
|
||||
* unnecessary overflow.
|
||||
*
|
||||
* Arguments
|
||||
* == = ======
|
||||
*
|
||||
* X (local input) REAL
|
||||
* Y (local input) REAL
|
||||
* X and Y specify the values x and y. X and Y are supposed to
|
||||
* be >= 0.
|
||||
*
|
||||
* == = ==================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL W, Z
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
W = MAX( X, Y )
|
||||
Z = MIN( X, Y )
|
||||
*
|
||||
IF( Z.EQ.ZERO ) THEN
|
||||
X = W
|
||||
ELSE
|
||||
X = W*SQRT( ONE+( Z / W )**2 )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SCOMBNRM2
|
||||
*
|
||||
END
|
||||
Loading…
Reference in New Issue