debian/0000755000000000000000000000000011640166116007170 5ustar debian/blacs1-pvm.postinst0000644000000000000000000000011511626511222012733 0ustar #!/bin/sh set -e if [ "$1" = "configure" ]; then ldconfig fi #DEBHELPER# debian/blacs-pvm-dev.links0000644000000000000000000000006211626511222012664 0ustar usr/lib/libblacs-pvm.so.1 usr/lib/libblacs-pvm.so debian/patches/0000755000000000000000000000000011640165026010616 5ustar debian/patches/05-TESTING_btprim_NX.patch0000644000000000000000000001775111640164277015202 0ustar --- /dev/null +++ blacs-pvm-1.1/TESTING/btprim_NX.f @@ -0,0 +1,319 @@ + SUBROUTINE BTSETUP( MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM, + $ TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, + $ IAM, NNODES ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX + INTEGER MEMLEN, CMEMLEN, OUTNUM, IAM, NNODES +* .. +* .. Array Arguments .. + INTEGER MEM(MEMLEN) + CHARACTER*1 CMEM(CMEMLEN) +* .. +* +* Purpose +* ======= +* BTSETUP: Does nothing on non-PVM platforms +* +* ==================================================================== +* .. Executable Statements .. + RETURN + END +* + INTEGER FUNCTION IBTMYPROC() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTMYPROC: returns a process number between 0 .. NPROCS-1. On +* systems not natively in this numbering scheme, translates to it. +* +* ==================================================================== +* +* .. External Functions .. + INTEGER MYNODE + EXTERNAL MYNODE +* .. +* .. Executable Statements .. +* + IBTMYPROC = MYNODE() + RETURN +* +* End of IBTMYPROC +* + END +* + INTEGER FUNCTION IBTNPROCS() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTNPROCS: returns the number of processes in the machine. +* +* ==================================================================== +* .. External Functions .. + INTEGER NUMNODES + EXTERNAL NUMNODES +* .. +* .. Executable Statements .. +* + IBTNPROCS = NUMNODES() +* + RETURN +* +* End of IBTNPROCS +* + END +* + SUBROUTINE BTSEND(DTYPE, N, BUFF, DEST, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, DEST, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTSEND: Communication primitive used to send messages independent +* of the BLACS. May safely be either locally or globally blocking. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is (same as PVM): +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (input) accepted as INTEGER array +* The array to be communicated. Its true data type is +* indicated by DTYPE. +* +* DEST (input) INTEGER +* The destination of the message. +* +* MSGID (input) INTEGER +* The message ID (AKA message tag or type). +* +* ===================================================================== +* .. External Functions .. + INTEGER IBTSIZEOF + EXTERNAL IBTSIZEOF +* .. +* .. Local Scalars .. + INTEGER LENGTH + INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Save statement .. + SAVE ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Data statements .. + DATA ISIZE /-50/ +* .. +* .. Executable Statements .. +* +* On first call, initialize size variables +* + IF( ISIZE .LT. 0 ) THEN + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') + DSIZE = IBTSIZEOF('D') + CSIZE = IBTSIZEOF('C') + ZSIZE = IBTSIZEOF('Z') + END IF +* +* Figure length of buffer +* + IF( DTYPE .EQ. 1 ) THEN + LENGTH = N + ELSE IF( DTYPE .EQ. 3 ) THEN + LENGTH = N * ISIZE + ELSE IF( DTYPE .EQ. 4 ) THEN + LENGTH = N * SSIZE + ELSE IF( DTYPE .EQ. 5 ) THEN + LENGTH = N * CSIZE + ELSE IF( DTYPE .EQ. 6 ) THEN + LENGTH = N * DSIZE + ELSE IF( DTYPE .EQ. 7 ) THEN + LENGTH = N * ZSIZE + END IF +* +* Send the message +* + CALL CSEND(MSGID, BUFF, LENGTH, DEST, 0) +* + RETURN +* +* End BTSEND +* + END +* + SUBROUTINE BTRECV(DTYPE, N, BUFF, SRC, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, SRC, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTRECV: Globally blocking receive. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is: +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (output) INTEGER +* The buffer to receive into. +* +* SRC (input) INTEGER +* The source of the message. +* +* MSGID (input) INTEGER +* The message ID. +* +* ===================================================================== +* +* .. External Functions .. + INTEGER IBTSIZEOF + EXTERNAL IBTSIZEOF +* .. +* .. Local Scalars .. + INTEGER LENGTH + INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Save statement .. + SAVE ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Data statements .. + DATA ISIZE /-50/ +* .. +* .. Executable Statements .. +* +* On first call, initialize size variables +* + IF( ISIZE .LT. 0 ) THEN + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') + DSIZE = IBTSIZEOF('D') + CSIZE = IBTSIZEOF('C') + ZSIZE = IBTSIZEOF('Z') + END IF +* +* Figure length of buffer +* + IF( DTYPE .EQ. 1 ) THEN + LENGTH = N + ELSE IF( DTYPE .EQ. 3 ) THEN + LENGTH = N * ISIZE + ELSE IF( DTYPE .EQ. 4 ) THEN + LENGTH = N * SSIZE + ELSE IF( DTYPE .EQ. 5 ) THEN + LENGTH = N * CSIZE + ELSE IF( DTYPE .EQ. 6 ) THEN + LENGTH = N * DSIZE + ELSE IF( DTYPE .EQ. 7 ) THEN + LENGTH = N * ZSIZE + END IF +* +* Receive the message +* + CALL CRECV(MSGID, BUFF, LENGTH) +* + RETURN +* +* End of BTRECV +* + END +* + INTEGER FUNCTION IBTSIZEOF(TYPE) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 TYPE +* .. +* +* Purpose +* ======= +* IBTSIZEOF: Returns the size, in bytes, of the 5 data types. +* If your platform has a different size for DOUBLE PRECISION, you must +* change the parameter statement in BLACSTEST as well. +* +* Arguments +* ========= +* TYPE (input) CHARACTER*1 +* The data type who's size is to be determined: +* 'I' : INTEGER +* 'S' : SINGLE PRECISION REAL +* 'D' : DOUBLE PRECISION REAL +* 'C' : SINGLE PRECISION COMPLEX +* 'Z' : DOUBLE PRECISION COMPLEX +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Local Scalars .. + INTEGER LENGTH +* .. +* .. Executable Statements .. +* + IF( LSAME(TYPE, 'I') ) THEN + LENGTH = 4 + ELSE IF( LSAME(TYPE, 'S') ) THEN + LENGTH = 4 + ELSE IF( LSAME(TYPE, 'D') ) THEN + LENGTH = 8 + ELSE IF( LSAME(TYPE, 'C') ) THEN + LENGTH = 8 + ELSE IF( LSAME(TYPE, 'Z') ) THEN + LENGTH = 16 + END IF + IBTSIZEOF = LENGTH +* + RETURN + END debian/patches/02-Bmake.patch0000644000000000000000000001731411640164034013101 0ustar --- /dev/null +++ blacs-pvm-1.1/Bmake.inc @@ -0,0 +1,161 @@ +#============================================================================= +#====================== SECTION 1: PATHS AND LIBRARIES ======================= +#============================================================================= +# The following macros specify the name and location of libraries required by +# the BLACS and its tester. +#============================================================================= + +# -------------------------------------- +# Make sure we've got a consistent shell +# -------------------------------------- + SHELL = /bin/sh + +# ----------------------------- +# The top level BLACS directory +# ----------------------------- + BTOPdir = $(BASEDIR) + +# --------------------------------------------------------------------------- +# The communication library your BLACS have been written for. +# Known choices (and the machines they run on) are: +# +# COMMLIB MACHINE +# ....... .............................................................. +# CMMD Thinking Machine's CM-5 +# MPI Wide variety of systems +# MPL IBM's SP series (SP1 and SP2) +# NX Intel's supercomputer series (iPSC2, iPSC/860, DELTA, PARAGON) +# PVM Most unix machines; See PVM User's Guide for details +# --------------------------------------------------------------------------- + COMMLIB = PVM + +# ------------------------------------------------------------- +# The platform identifier to suffix to the end of library names +# ------------------------------------------------------------- +# PLAT = $(PVM_ARCH) + PLAT = LINUX + +# ---------------------------------------------------------- +# Name and location of the BLACS library. See section 2 for +# details on BLACS debug level (BLACSDBGLVL). +# ---------------------------------------------------------- + BLACSdir = $(BTOPdir)/LIB + BLACSDBGLVL = 0 + BLACSLIB = $(BLACSdir)/blacs_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + +# ------------------------------------- +# Name and location of the PVM library. +# ------------------------------------- + PVMdir = /usr + PVMLIBdir = $(PVMdir)/lib + PVMINCdir = $(PVMdir)/include + PVMLIB = -lfpvm3 -lpvm3 + +# ------------------------------------- +# All libraries required by the tester. +# ------------------------------------- +# BTLIBS = $(BLACSLIB) $(PVMLIB) + +# ---------------------------------------------------------------- +# The directory to put the installation help routines' executables +# ---------------------------------------------------------------- + INSTdir = $(HOME)/pvm3/bin/$(PLAT) + +# ------------------------------------------------ +# The name and location of the tester's executable +# ------------------------------------------------ + TESTdir = $(BTOPdir)/TESTING/EXE + FTESTexe = $(TESTdir)/xFbtest_$(COMMLIB)-$(BLACSDBGLVL) + CTESTexe = $(TESTdir)/xCbtest_$(COMMLIB)-$(BLACSDBGLVL) +#============================================================================= +#=============================== End SECTION 1 =============================== +#============================================================================= + + +#============================================================================= +#========================= SECTION 2: BLACS INTERNALS ======================== +#============================================================================= +# The following macro definitions set preprocessor values for the BLACS. +# The file Bconfig.h sets these values if they are not set by the makefile. +# User's compiling only the tester can skip this entire section. +#============================================================================= + +# ----------------------------------------------------------------------- +# The directory to find the required communication library include files, +# if they are required by your system. +# ----------------------------------------------------------------------- + SYSINC = -I$(PVMINCdir) + +# --------------------------------------------------------------------------- +# The Fortran 77 to C interface to be used. If you are unsure of the correct +# setting for your platform, compile and run BLACS/INSTALL/xintface. +# Choices are: Add_, NoChange, UpCase, or f77IsF2C. +# --------------------------------------------------------------------------- + INTFACE = -DAdd_ + +# -------------------------------------------------------------------- +# By default, the BLACS use getrusage() to determine cputime. If this +# is not satisfactory, can use times() instead, by substituting the +# following line for the empty macro definition below. +# WHICHTIMER = -DUseTIMES +# -------------------------------------------------------------------- + WHICHTIMER = + +# ----------------------------------------------------------------- +# If you want output to go to your /tmp/pvml. files instead of +# to process 0's standard out, substitute the following line for +# the empty macro definition below. +# CATCHOUT = -DBLACSNoCatchout +# ----------------------------------------------------------------- + CATCHOUT = + +# ------------------------------------------------------------------ +# These macros set the debug level for the BLACS. The fastest +# code is produced by BlacsDebugLvl 0. Higher levels provide +# more debug information at the cost of performance. Present levels +# of debug are: +# 0 : No debug information +# 1 : Mainly parameter checking. +# ------------------------------------------------------------------ + DEBUGLVL = -DBlacsDebugLvl=$(BLACSDBGLVL) + +# ------------------------------------------------------------------------- +# All BLACS definitions needed for compile (DEFS1 contains definitions used +# by all BLACS versions). +# ------------------------------------------------------------------------- + DEFS1 = -DSYSINC $(SYSINC) $(INTFACE) $(DEFBSTOP) $(DEFCOMBTOP) $(DEBUGLVL) + BLACSDEFS = $(DEFS1) $(CATCHOUT) $(WHICHTIMER) +#============================================================================= +#=============================== End SECTION 2 =============================== +#============================================================================= + + +#============================================================================= +#=========================== SECTION 3: COMPILERS ============================ +#============================================================================= +# The following macros specify compilers, linker/loaders, the archiver, +# and their options. Some of the fortran files need to be compiled with no +# optimization. This is the F77NO_OPTFLAG. The usage of the remaining +# macros should be obvious from the names. +#============================================================================= + F77 = gfortran $(FPIC) -ffunction-sections + F77NO_OPTFLAGS = -w + F77FLAGS = $(F77NO_OPTFLAGS) -O4 + F77LOADER = $(F77) + F77LOADFLAGS = + CC = gcc $(FPIC) -ffunction-sections + CCFLAGS = -O4 + CCLOADER = $(CC) + CCLOADFLAGS = + +# -------------------------------------------------------------------------- +# The archiver and the flag(s) to use when building an archive (library). +# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo. +# -------------------------------------------------------------------------- + ARCH = ar + ARCHFLAGS = r + RANLIB = ranlib + +#============================================================================= +#=============================== End SECTION 3 =============================== +#============================================================================= debian/patches/06-TESTING.patch0000644000000000000000000333110311640164744013211 0ustar --- /dev/null +++ blacs-pvm-1.1/TESTING/comb.dat @@ -0,0 +1,20 @@ +3 Number of OPs +'+' '>' '<' Combine operations to perform +3 Number of scopes +'R' 'C' 'A' values for scopes +2 Repeatability flag (0=no-rep, 1=rep, 2=both) +2 Coherence flag (0=no-coh, 1=coh, 2=both) +4 Number of topologies +' ' 'T' 'H' 'f' 'M' TOP +6 Number of matrices +3 1 2 25 13 0 M +5 1 3 19 32 0 N +5 1 4 25 14 1 LDASRC +9 1 5 25 22 1 LDADEST +4 1 -1 25 22 1 LDI +4 Number of dests +0 -1 0 2 RDEST +0 -1 1 0 CDEST +4 Number of grids +2 1 4 1 1 8 3 NPROW +2 4 1 3 7 1 2 NPCOL --- /dev/null +++ blacs-pvm-1.1/TESTING/btprim_CMMD.f @@ -0,0 +1,327 @@ + SUBROUTINE BTSETUP( MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM, + $ TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, + $ IAM, NNODES ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX + INTEGER MEMLEN, CMEMLEN, OUTNUM, IAM, NNODES +* .. +* .. Array Arguments .. + INTEGER MEM(MEMLEN) + CHARACTER*1 CMEM(CMEMLEN) +* .. +* +* Purpose +* ======= +* BTSETUP: Does nothing on non-PVM platforms +* +* ==================================================================== +* .. Executable Statements .. + RETURN + END +* + INTEGER FUNCTION IBTMYPROC() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTMYPROC: returns a process number between 0 .. NPROCS-1. On +* systems not natively in this numbering scheme, translates to it. +* +* ==================================================================== +* .. External Functions .. + INTEGER CMMD_SELF_ADDRESS + EXTERNAL CMMD_SELF_ADDRESS +* .. +* .. Executable Statements .. +* + IBTMYPROC = CMMD_SELF_ADDRESS() + RETURN +* +* End of IBTMYPROC +* + END +* + INTEGER FUNCTION IBTNPROCS() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTNPROCS: returns the number of processes in the machine. +* +* ==================================================================== +* .. External Functions .. + INTEGER CMMD_PARTITION_SIZE + EXTERNAL CMMD_PARTITION_SIZE +* .. +* .. Executable Statements .. +* + IBTNPROCS = CMMD_PARTITION_SIZE() +* + RETURN +* +* End of IBTNPROCS +* + END +* + SUBROUTINE BTSEND(DTYPE, N, BUFF, DEST, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, DEST, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTSEND: Communication primitive used to send messages independent +* of the BLACS. May safely be either locally or globally blocking. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is (same as PVM): +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (input) accepted as INTEGER array +* The array to be communicated. Its true data type is +* indicated by DTYPE. +* +* DEST (input) INTEGER +* The destination of the message. +* +* MSGID (input) INTEGER +* The message ID (AKA message tag or type). +* +* ===================================================================== +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. Local Scalars .. + INTEGER I, IAM, LENGTH + INTEGER LENGTH + INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Save statement .. + SAVE ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Data statements .. + DATA ISIZE /-50/ +* .. +* .. Executable Statements .. +* +* On first call, initialize size variables +* + IF( ISIZE .LT. 0 ) THEN + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') + DSIZE = IBTSIZEOF('D') + CSIZE = IBTSIZEOF('C') + ZSIZE = IBTSIZEOF('Z') + END IF +* +* Figure length of buffer +* + IF( DTYPE .EQ. 1 ) THEN + LENGTH = N + ELSE IF( DTYPE .EQ. 3 ) THEN + LENGTH = N * ISIZE + ELSE IF( DTYPE .EQ. 4 ) THEN + LENGTH = N * SSIZE + ELSE IF( DTYPE .EQ. 5 ) THEN + LENGTH = N * CSIZE + ELSE IF( DTYPE .EQ. 6 ) THEN + LENGTH = N * DSIZE + ELSE IF( DTYPE .EQ. 7 ) THEN + LENGTH = N * ZSIZE + END IF +* +* Send the message +* + IF(DEST .EQ. -1) THEN + IAM = IBTMYPROC() + DO 10 I = 0, IBTNPROCS()-1 + IF( I .NE. IAM ) + $ CALL CMMD_SEND_BLOCK(I, MSGID, BUFF, LENGTH) + 10 CONTINUE + ELSE + CALL CMMD_SEND_BLOCK(DEST, MSGID, BUFF, LENGTH) + END IF +* + RETURN +* +* End BTSEND +* + END +* + SUBROUTINE BTRECV(DTYPE, N, BUFF, SRC, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, SRC, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTRECV: Globally blocking receive. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is: +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (output) INTEGER +* The buffer to receive into. +* +* SRC (input) INTEGER +* The source of the message. +* +* MSGID (input) INTEGER +* The message ID. +* +* ===================================================================== +* +* .. External Functions .. + INTEGER IBTSIZEOF + EXTERNAL IBTSIZEOF +* .. +* .. Local Scalars .. + INTEGER LENGTH + INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Save statement .. + SAVE ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Data statements .. + DATA ISIZE /-50/ +* .. +* .. Executable Statements .. +* +* On first call, initialize size variables +* + IF( ISIZE .LT. 0 ) THEN + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') + DSIZE = IBTSIZEOF('D') + CSIZE = IBTSIZEOF('C') + ZSIZE = IBTSIZEOF('Z') + END IF +* +* Figure length of buffer +* + IF( DTYPE .EQ. 1 ) THEN + LENGTH = N + ELSE IF( DTYPE .EQ. 3 ) THEN + LENGTH = N * ISIZE + ELSE IF( DTYPE .EQ. 4 ) THEN + LENGTH = N * SSIZE + ELSE IF( DTYPE .EQ. 5 ) THEN + LENGTH = N * CSIZE + ELSE IF( DTYPE .EQ. 6 ) THEN + LENGTH = N * DSIZE + ELSE IF( DTYPE .EQ. 7 ) THEN + LENGTH = N * ZSIZE + END IF +* +* Receive the message +* + CALL CMMD_RECEIVE_BLOCK(SRC, MSGID, BUFF, LENGTH) +* + RETURN +* +* End of BTRECV +* + END +* + INTEGER FUNCTION IBTSIZEOF(TYPE) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 TYPE +* .. +* +* Purpose +* ======= +* IBTSIZEOF: Returns the size, in bytes, of the 5 data types. +* If your platform has a different size for DOUBLE PRECISION, you must +* change the parameter statement in BLACSTEST as well. +* +* Arguments +* ========= +* TYPE (input) CHARACTER*1 +* The data type who's size is to be determined: +* 'I' : INTEGER +* 'S' : SINGLE PRECISION REAL +* 'D' : DOUBLE PRECISION REAL +* 'C' : SINGLE PRECISION COMPLEX +* 'Z' : DOUBLE PRECISION COMPLEX +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Local Scalars .. + INTEGER LENGTH +* .. +* .. Executable Statements .. +* + IF( LSAME(TYPE, 'I') ) THEN + LENGTH = 4 + ELSE IF( LSAME(TYPE, 'S') ) THEN + LENGTH = 4 + ELSE IF( LSAME(TYPE, 'D') ) THEN + LENGTH = 8 + ELSE IF( LSAME(TYPE, 'C') ) THEN + LENGTH = 8 + ELSE IF( LSAME(TYPE, 'Z') ) THEN + LENGTH = 16 + END IF + IBTSIZEOF = LENGTH +* + RETURN + END --- /dev/null +++ blacs-pvm-1.1/TESTING/bsbr.dat @@ -0,0 +1,18 @@ +3 Number of scopes +'R' 'C' 'A' values for scopes +8 Number of topologies +'I' 'S' '1' 'd' 'm' ' ' 'T' 'H' TOP +5 Number of shapes +'G' 'U' 'U' 'L' 'L' UPLO +'E' 'U' 'N' 'U' 'N' DIAG +5 Number of matrices +2 1 25 13 0 M +2 7 19 32 0 N +3 3 25 14 1 LDASRC +2 2 25 22 1 LDADEST +4 Number of src/dest pairs +0 1 3 2 RSRC +0 0 1 1 CSRC +4 Number of grids +2 4 1 1 7 1 4 NPROW +2 1 3 4 1 8 2 NPCOL --- /dev/null +++ blacs-pvm-1.1/TESTING/blacstest.f @@ -0,0 +1,21722 @@ + PROGRAM BLACSTEST +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* This is the driver for the BLACS test suite. +* +* Arguments +* ========= +* None. Input is done via the data files indicated below. +* +* Input Files +* =========== +* The following input files must reside in the current working +* directory: +* +* bt.dat -- input parameters for the test run as a whole +* sdrv.dat -- input parameters for point-to-point testing +* bsbr.dat -- input parameters for broadcast testing +* comb.dat -- input parameters for combine testing +* +* Output Files +* ============ +* Test results are generated and sent to output file as +* specified by the user in bt.dat. +* +* =================================================================== +* +* .. Parameters .. + INTEGER CMEMSIZ, MEMELTS + PARAMETER( MEMELTS = 250000 ) + PARAMETER( CMEMSIZ = 10000 ) +* .. +* .. External Functions .. + LOGICAL ALLPASS + INTEGER IBTMSGID, IBTSIZEOF + REAL SBTEPS + DOUBLE PRECISION DBTEPS + EXTERNAL ALLPASS, IBTMSGID, SBTEPS, DBTEPS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_PINFO, BTSETUP, RDBTIN +* .. +* .. Local Scalars .. + INTEGER I, IAM, NNODES, VERB, OUTNUM, MEMLEN, NPREC, ISIZE, DSIZE + LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX +* .. +* .. Local Arrays .. + CHARACTER*1 CMEM(CMEMSIZ), PREC(9) + INTEGER IPREC(9), ITMP(2) + DOUBLE PRECISION MEM(MEMELTS) +* .. +* .. Executable Statements .. +* + ISIZE = IBTSIZEOF('I') + DSIZE = IBTSIZEOF('D') +* +* Get initial process information, and initialize message IDs +* + CALL BLACS_PINFO( IAM, NNODES ) + ITMP(1) = IBTMSGID() +* +* Call BLACS_GRIDINIT so BLACS set up some system stuff: should +* make it possible for the user to print, read input files, etc. +* + IF( NNODES .GT. 0 ) THEN + CALL BLACS_GET( 0, 0, ITMP ) + CALL BLACS_GRIDINIT(ITMP, 'c', 1, NNODES) + CALL BLACS_GRIDEXIT(ITMP) + END IF +* +* Read in what tests to do +* + IF( IAM .EQ. 0 ) + $ CALL RDBTIN( TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, NPREC, + $ PREC, VERB, OUTNUM ) +* + MEMLEN = (MEMELTS * DSIZE) / ISIZE +* +* Get process info for communication, and create virtual machine +* if necessary +* + CALL BTSETUP( MEM, MEMLEN, CMEM, CMEMSIZ, OUTNUM, TESTSDRV, + $ TESTBSBR, TESTCOMB, TESTAUX, IAM, NNODES ) +* +* Send out RDBTIN information +* + IF( IAM .EQ. 0 ) THEN +* +* Store test info in back of precision array +* + ITMP(1) = NPREC + ITMP(2) = VERB + CALL BTSEND( 3, 2, ITMP, -1, IBTMSGID() ) + DO 10 I = 1, 9 + IPREC(I) = 0 + 10 CONTINUE + DO 20 I = 1, NPREC + IF( PREC(I) .EQ. 'I' ) THEN + IPREC(I) = 1 + ELSE IF( PREC(I) .EQ. 'S' ) THEN + IPREC(I) = 2 + ELSE IF( PREC(I) .EQ. 'D' ) THEN + IPREC(I) = 3 + ELSE IF( PREC(I) .EQ. 'C' ) THEN + IPREC(I) = 4 + ELSE IF( PREC(I) .EQ. 'Z' ) THEN + IPREC(I) = 5 + END IF + 20 CONTINUE + IF( TESTSDRV ) IPREC(6) = 1 + IF( TESTBSBR ) IPREC(7) = 1 + IF( TESTCOMB ) IPREC(8) = 1 + IF( TESTAUX ) IPREC(9) = 1 + CALL BTSEND( 3, 9, IPREC, -1, IBTMSGID()+1 ) + ELSE + CALL BTRECV( 3, 2, ITMP, 0, IBTMSGID() ) + NPREC = ITMP(1) + VERB = ITMP(2) + CALL BTRECV( 3, 9, IPREC, 0, IBTMSGID()+1 ) + DO 30 I = 1, NPREC + IF( IPREC(I) .EQ. 1 ) THEN + PREC(I) = 'I' + ELSE IF( IPREC(I) .EQ. 2 ) THEN + PREC(I) = 'S' + ELSE IF( IPREC(I) .EQ. 3 ) THEN + PREC(I) = 'D' + ELSE IF( IPREC(I) .EQ. 4 ) THEN + PREC(I) = 'C' + ELSE IF( IPREC(I) .EQ. 5 ) THEN + PREC(I) = 'Z' + END IF + 30 CONTINUE + TESTSDRV = ( IPREC(6) .EQ. 1 ) + TESTBSBR = ( IPREC(7) .EQ. 1 ) + TESTCOMB = ( IPREC(8) .EQ. 1 ) + TESTAUX = ( IPREC(9) .EQ. 1 ) + ENDIF +* + IF( TESTSDRV .OR. TESTBSBR .OR. TESTCOMB .OR. TESTAUX ) THEN +* +* Find maximal machine epsilon for single and double precision +* + ITMP(1) = INT( SBTEPS() ) + ITMP(1) = INT( DBTEPS() ) +* + CALL RUNTESTS( MEM, MEMLEN, CMEM, CMEMSIZ, PREC, NPREC, OUTNUM, + $ VERB, TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX ) +* + END IF +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM,1000) + WRITE(OUTNUM,1000) + IF( ALLPASS(.TRUE.) ) THEN + WRITE(OUTNUM,2000) 'NO' + ELSE + WRITE(OUTNUM,2000) ' ' + END IF + WRITE(OUTNUM,1000) + WRITE(OUTNUM,1000) + IF( OUTNUM.NE.0 .AND. OUTNUM.NE.6 ) CLOSE(OUTNUM) + ENDIF +* + CALL BLACS_EXIT(0) + 1000 FORMAT('=======================================') + 2000 FORMAT('THERE WERE ',A2,' FAILURES IN THIS TEST RUN') + STOP +* +* End BLACSTESTER +* + END +* + SUBROUTINE RUNTESTS( MEM, MEMLEN, CMEM, CMEMLEN, PREC, NPREC, + $ OUTNUM, VERB, TESTSDRV, TESTBSBR, TESTCOMB, + $ TESTAUX ) +* +* .. Scalar Arguments .. + INTEGER MEMLEN, CMEMLEN, NPREC, OUTNUM, VERB, IAM, NNODES + LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX +* .. +* .. Array Arguments .. + CHARACTER*1 CMEM(CMEMLEN), PREC(NPREC) + INTEGER MEM(MEMLEN) +* .. +* .. External Functions .. + INTEGER IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX + EXTERNAL IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX +* .. +* .. External Subroutines .. + EXTERNAL CSDRVTEST, DSDRVTEST, ISDRVTEST, SSDRVTEST, ZSDRVTEST + EXTERNAL CBSBRTEST, DBSBRTEST, IBSBRTEST, SBSBRTEST, ZBSBRTEST + EXTERNAL ISUMTEST, SSUMTEST, DSUMTEST, CSUMTEST, ZSUMTEST + EXTERNAL IAMXTEST, SAMXTEST, DAMXTEST, CAMXTEST, ZAMXTEST + EXTERNAL IAMNTEST, SAMNTEST, DAMNTEST, CAMNTEST, ZAMNTEST + EXTERNAL AUXTEST, BTSEND, BTRECV, BTINFO +* .. +* .. Local Scalars .. + INTEGER NSCOPE, NOP, NTOP, NSHAPE, NMAT, NSRC, NDEST, NGRID + INTEGER TREP, TCOH, OPPTR, SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR + INTEGER MPTR, NPTR, LDSPTR, LDDPTR, LDIPTR + INTEGER RSRCPTR, CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR + INTEGER ISEEDPTR, RAPTR, CAPTR, CTXTPTR, WORKPTR, WORKLEN + INTEGER MEMUSED, CMEMUSED, I, J, K + INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Local Arrays .. + INTEGER ITMP(4) +* .. +* .. Executable Statements .. +* + IAM = IBTMYPROC() + NNODES = IBTNPROCS() + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') + DSIZE = IBTSIZEOF('D') + CSIZE = IBTSIZEOF('C') + ZSIZE = IBTSIZEOF('Z') +* + IF( IAM.EQ.0 ) THEN + CALL BLACS_GET( 0, 2, I ) + WRITE(OUTNUM,3000) + WRITE(OUTNUM,3000) + WRITE(OUTNUM,2000) I + WRITE(OUTNUM,3000) + WRITE(OUTNUM,3000) + END IF +* + IF( TESTAUX ) THEN +* +* Each process will make sure that BLACS_PINFO returns +* the same value as BLACS_SETUP, and send a packet +* to node 0 saying whether it was. +* + CALL BLACS_PINFO( ITMP(1), ITMP(3) ) + CALL BLACS_SETUP( ITMP(2), ITMP(4) ) + IF( IAM .EQ. 0 ) THEN + DO 35 I = 0, NNODES-1 + IF( I .NE. 0 ) + $ CALL BTRECV( 3, 4, ITMP, I, IBTMSGID()+2 ) + IF( ITMP(1) .NE. ITMP(2) ) + $ WRITE( OUTNUM, 1000 ) ITMP(1), ITMP(2) + IF( (ITMP(3).NE.ITMP(4)) .OR. (ITMP(3).NE.NNODES) ) + $ WRITE( OUTNUM, 1000 ) ITMP(3), ITMP(4), NNODES + 35 CONTINUE + ELSE + CALL BTSEND( 3, 4, ITMP, 0, IBTMSGID()+2 ) + ENDIF + ENDIF +* +* Run point-to-point tests as appropriate +* + IF( TESTSDRV ) THEN +* +* Get test info +* + CALL BTINFO( 'SDRV', MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, + $ CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP, + $ NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR, + $ TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, + $ LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR, + $ CDESTPTR, PPTR, QPTR ) +* +* iseedptr used as tests passed/failed array, so it must +* be of size NTESTS -- It's not used unless VERB < 2 +* + CTXTPTR = MEMUSED + 1 + ISEEDPTR = CTXTPTR + NGRID + MEMUSED = ISEEDPTR - 1 + IF( VERB .LT. 2 ) + $ MEMUSED = MEMUSED + NSHAPE * NMAT * NSRC * NGRID +* + CALL MAKEGRIDS( MEM(CTXTPTR), OUTNUM, NGRID, MEM(PPTR), + $ MEM(QPTR) ) +* +* Call individual tests as appropriate. +* + DO 10 I = 1, NPREC + IF( PREC(I) .EQ. 'I' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ISIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ISIZE + CALL ISDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ MEM(RDESTPTR), MEM(CDESTPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) +* + ELSE IF( PREC(I) .EQ. 'S' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, SSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / SSIZE + CALL SSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ MEM(RDESTPTR), MEM(CDESTPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) +* + ELSE IF( PREC(I) .EQ. 'D' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, DSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / DSIZE + CALL DSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ MEM(RDESTPTR), MEM(CDESTPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) +* + ELSE IF( PREC(I) .EQ. 'C' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, CSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / CSIZE + CALL CSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ MEM(RDESTPTR), MEM(CDESTPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) +* + ELSE IF( PREC(I) .EQ. 'Z' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ZSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ZSIZE + CALL ZSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ MEM(RDESTPTR), MEM(CDESTPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) + END IF + 10 CONTINUE + CALL FREEGRIDS( NGRID, MEM(CTXTPTR) ) + END IF +* + IF( TESTBSBR ) THEN +* +* Get test info +* + CALL BTINFO( 'BSBR', MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, + $ CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP, + $ NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR, + $ TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, + $ LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR, + $ CDESTPTR, PPTR, QPTR ) +* +* iseedptr used as tests passed/failed array, so it must +* be of size NTESTS -- It's not used unless VERB < 2 +* + CTXTPTR = MEMUSED + 1 + ISEEDPTR = CTXTPTR + NGRID + MEMUSED = ISEEDPTR - 1 + IF( VERB .LT. 2 ) + $ MEMUSED = MEMUSED + NSCOPE*NTOP*NSHAPE*NMAT*NSRC*NGRID +* + CALL MAKEGRIDS( MEM(CTXTPTR), OUTNUM, NGRID, MEM(PPTR), + $ MEM(QPTR) ) +* +* Call individual tests as appropriate. +* + DO 20 I = 1, NPREC + IF( PREC(I) .EQ. 'I' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ISIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ISIZE + CALL IBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR), + $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) +* + ELSE IF( PREC(I) .EQ. 'S' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, SSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / SSIZE + CALL SBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR), + $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) +* + ELSE IF( PREC(I) .EQ. 'D' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, DSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / DSIZE + CALL DBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR), + $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) +* + ELSE IF( PREC(I) .EQ. 'C' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, CSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / CSIZE + CALL CBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR), + $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) +* + ELSE IF( PREC(I) .EQ. 'Z' ) THEN +* + WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ZSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ZSIZE + CALL ZBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR), + $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR), + $ CMEM(DIAGPTR), NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), + $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR), + $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN) +* + END IF +* + 20 CONTINUE + CALL FREEGRIDS( NGRID, MEM(CTXTPTR) ) + END IF + IF( TESTCOMB ) THEN +* +* Get test info +* + CALL BTINFO( 'COMB', MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, + $ CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP, + $ NSHAPE, NMAT, NDEST, NGRID, OPPTR, SCOPEPTR, + $ TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, + $ LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR, + $ CDESTPTR, PPTR, QPTR ) + CTXTPTR = MEMUSED + 1 + MEMUSED = CTXTPTR + NGRID - 1 +* +* Find space required by RA and CA arrays +* + K = 0 + DO 40 J = 0, NOP-1 + IF( CMEM(OPPTR+J).EQ.'>' .OR. CMEM(OPPTR+J).EQ.'<' ) THEN + DO 30 I = 0, NMAT +* +* NOTE: here we assume ipre+ipost = 4*M +* + K = MAX0( K, 4*MEM(MPTR+I) ) + IF ( MEM(LDIPTR+I) .NE. -1 ) + $ K = MAX0( K, MEM(NPTR+I)*MEM(LDIPTR+I) + + $ 4*MEM(MPTR+I) ) + 30 CONTINUE + END IF + 40 CONTINUE + RAPTR = MEMUSED + 1 + CAPTR = RAPTR + K +* +* iseed array also used as tests passed/failed array, so it must +* be of size MAX( 4*NNODES, NTESTS ) +* + ISEEDPTR = CAPTR + K + I = 0 + IF( VERB.LT.2 ) I = NSCOPE * NTOP * NMAT * NDEST * NGRID + MEMUSED = ISEEDPTR + MAX( 4*NNODES, I ) +* + CALL MAKEGRIDS( MEM(CTXTPTR), OUTNUM, NGRID, MEM(PPTR), + $ MEM(QPTR) ) +* +* Call individual tests as appropriate. +* + DO 60 I = 1, NPREC + DO 50 J = 0, NOP-1 + IF( PREC(I) .EQ. 'I' ) THEN + WORKPTR = SAFEINDEX(MEMUSED, ISIZE, ISIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ISIZE + IF( CMEM(OPPTR+J) .EQ. '+' ) THEN + CALL ISUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), NDEST, + $ MEM(RDESTPTR), MEM(CDESTPTR), NGRID, + $ MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), + $ WORKLEN) + ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN + CALL IAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), + $ MEM(LDIPTR), NDEST, MEM(RDESTPTR), + $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR), + $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR), + $ MEM(RAPTR), MEM(CAPTR), K, + $ MEM(WORKPTR), WORKLEN) + ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN + CALL IAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), + $ MEM(LDIPTR), NDEST, MEM(RDESTPTR), + $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR), + $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR), + $ MEM(RAPTR), MEM(CAPTR), K, + $ MEM(WORKPTR), WORKLEN) + END IF + ELSE IF( PREC(I) .EQ. 'S' ) THEN + WORKPTR = SAFEINDEX(MEMUSED, ISIZE, SSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / SSIZE + IF( CMEM(OPPTR+J) .EQ. '+' ) THEN + CALL SSUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), NDEST, + $ MEM(RDESTPTR), MEM(CDESTPTR), NGRID, + $ MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), + $ WORKLEN) + ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN + CALL SAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), + $ MEM(LDIPTR), NDEST, MEM(RDESTPTR), + $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR), + $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR), + $ MEM(RAPTR), MEM(CAPTR), K, + $ MEM(WORKPTR), WORKLEN) + ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN + CALL SAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), + $ MEM(LDIPTR), NDEST, MEM(RDESTPTR), + $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR), + $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR), + $ MEM(RAPTR), MEM(CAPTR), K, + $ MEM(WORKPTR), WORKLEN) + END IF + ELSE IF( PREC(I) .EQ. 'C' ) THEN + WORKPTR = SAFEINDEX(MEMUSED, ISIZE, CSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / CSIZE + IF( CMEM(OPPTR+J) .EQ. '+' ) THEN + CALL CSUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), NDEST, + $ MEM(RDESTPTR), MEM(CDESTPTR), NGRID, + $ MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), + $ WORKLEN) + ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN + CALL CAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), + $ MEM(LDIPTR), NDEST, MEM(RDESTPTR), + $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR), + $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR), + $ MEM(RAPTR), MEM(CAPTR), K, + $ MEM(WORKPTR), WORKLEN) + ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN + CALL CAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), + $ MEM(LDIPTR), NDEST, MEM(RDESTPTR), + $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR), + $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR), + $ MEM(RAPTR), MEM(CAPTR), K, + $ MEM(WORKPTR), WORKLEN) + END IF + ELSE IF( PREC(I) .EQ. 'Z' ) THEN + WORKPTR = SAFEINDEX(MEMUSED, ISIZE, ZSIZE) + WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ZSIZE + IF( CMEM(OPPTR+J) .EQ. '+' ) THEN + CALL ZSUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), NDEST, + $ MEM(RDESTPTR), MEM(CDESTPTR), NGRID, + $ MEM(CTXTPTR), MEM(PPTR), MEM(QPTR), + $ MEM(ISEEDPTR), MEM(WORKPTR), + $ WORKLEN) + ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN + CALL ZAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), + $ MEM(LDIPTR), NDEST, MEM(RDESTPTR), + $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR), + $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR), + $ MEM(RAPTR), MEM(CAPTR), K, + $ MEM(WORKPTR), WORKLEN) + ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN + CALL ZAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE, + $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR), + $ NMAT, MEM(MPTR), MEM(NPTR), + $ MEM(LDSPTR), MEM(LDDPTR), + $ MEM(LDIPTR), NDEST, MEM(RDESTPTR), + $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR), + $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR), + $ MEM(RAPTR), MEM(CAPTR), K, + $ MEM(WORKPTR), WORKLEN) + END IF + END IF + 50 CONTINUE + 60 CONTINUE + CALL FREEGRIDS( NGRID, MEM(CTXTPTR) ) + END IF +* + IF( TESTAUX ) THEN + CALL AUXTEST( OUTNUM, MEM, MEMLEN ) + END IF +* + 1000 FORMAT('AUXILIARY ERROR - IAM MISMATCH: BLACS_PINFO RETURNED',I4, + $ /,' BLACS_SETUP RETURNED',I4,'.') + 1500 FORMAT('AUXILIARY ERROR - NPROC MISMATCH: BLACS_PINFO RETURNED', + $ I4,/,' BLACS_SETUP RETURNED',I4,', TESTER THINKS',I4,'.') + 2000 FORMAT('BEGINNING BLACS TESTING, BLACS DEBUG LEVEL =',I2) + 3000 FORMAT('==============================================') + RETURN +* +* End of RUNTESTS +* + END +* + SUBROUTINE MAKEGRIDS( CONTEXTS, OUTNUM, NGRIDS, P, Q ) + INTEGER NGRIDS, OUTNUM + INTEGER CONTEXTS(NGRIDS), P(NGRIDS), Q(NGRIDS) + INTEGER IBTMYPROC + EXTERNAL IBTMYPROC + INTEGER NPROW, NPCOL, MYROW, MYCOL, I +* + DO 10 I = 1, NGRIDS + CALL BLACS_GET( 0, 0, CONTEXTS(I) ) + CALL BLACS_GRIDINIT( CONTEXTS(I), 'r', P(I), Q(I) ) + 10 CONTINUE +* + DO 20 I = 1, NGRIDS + CALL BLACS_GRIDINFO( CONTEXTS(I), NPROW, NPCOL, MYROW, MYCOL ) + IF( NPROW .GT. 0 ) THEN + IF( NPROW.NE.P(I) .OR. NPCOL.NE.Q(I) ) THEN + IF( IBTMYPROC() .NE. 0 ) OUTNUM = 6 + WRITE(OUTNUM,1000) I + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + CALL BLACS_ABORT( CONTEXTS(I), -1 ) + END IF + END IF + 20 CONTINUE +* + 1000 FORMAT('Grid creation error trying to create grid #',I3) + RETURN + END +* + SUBROUTINE FREEGRIDS( NGRIDS, CONTEXTS ) + INTEGER NGRIDS + INTEGER CONTEXTS(NGRIDS) + INTEGER I, NPROW, NPCOL, MYROW, MYCOL +* + DO 10 I = 1, NGRIDS + CALL BLACS_GRIDINFO( CONTEXTS(I), NPROW, NPCOL, MYROW, MYCOL ) + IF( MYROW.LT.NPROW .AND. MYCOL.LT.NPCOL ) + $ CALL BLACS_GRIDEXIT( CONTEXTS(I) ) + 10 CONTINUE + RETURN + END +* + SUBROUTINE AUXTEST( OUTNUM, MEM, MEMLEN ) +* +* .. Scalar Arguments .. + INTEGER OUTNUM, MEMLEN +* .. +* .. Array Arguments .. + INTEGER MEM(MEMLEN) +* .. +* .. External Functions .. + LOGICAL ALLPASS + INTEGER IBTMYPROC, IBTMSGID, BLACS_PNUM + DOUBLE PRECISION DWALLTIME00 + EXTERNAL ALLPASS, IBTMYPROC, IBTMSGID, BLACS_PNUM + EXTERNAL DWALLTIME00 +* .. +* .. External Subroutines .. + EXTERNAL BLACS_PINFO, BLACS_GRIDINIT, BLACS_GRIDMAP + EXTERNAL BLACS_FREEBUFF, BLACS_GRIDEXIT, BLACS_ABORT + EXTERNAL BLACS_GRIDINFO, BLACS_PCOORD, BLACS_BARRIER + EXTERNAL BLACS_SET +* .. +* .. Local Scalars .. + LOGICAL AUXPASSED, PASSED, IPRINT + INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, CTXT, CTXT2, LDA + INTEGER I, J, K + DOUBLE PRECISION DTIME, DEPS +* .. +* .. Local Arrays .. + DOUBLE PRECISION START(2), STST(2), KEEP(2) +* .. +* .. Executable Statements .. +* + IPRINT = ( IBTMYPROC() .EQ. 0 ) + IF( IPRINT ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM,1000) + WRITE(OUTNUM,*) ' ' + END IF + CALL BLACS_PINFO( I, NPROCS ) + IF( NPROCS .LT. 2 ) THEN + IF( IPRINT ) + $ WRITE(OUTNUM,*) 'NOT ENOUGH PROCESSES TO PERFORM AUXTESTS' + RETURN + END IF +* +* Make sure BLACS_PNUM and BLACS_PCOORD are inverses of each other +* + IF( IPRINT ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM,*) 'RUNNING BLACS_PNUM/BLACS_PCOORD TEST' + END IF + PASSED = .TRUE. + NPROCS = NPROCS - MOD(NPROCS,2) + CALL BLACS_GET( 0, 0, CTXT ) + CALL BLACS_GRIDINIT( CTXT, 'r', 1, NPROCS ) + CALL BLACS_GRIDINFO( CTXT, NPROW, NPCOL, MYROW, MYCOL ) + IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL ) GOTO 100 + DO 10 I = 1, NPROCS + K = BLACS_PNUM( CTXT, 0, I-1 ) + CALL BLACS_PCOORD( CTXT, BLACS_PNUM( CTXT, 0, I-1 ), J, K ) + IF( PASSED ) PASSED = ( J.EQ.0 .AND. K.EQ.I-1 ) + 10 CONTINUE + K = 1 + IF( PASSED ) K = 0 + CALL IGSUM2D( CTXT, 'a', ' ', 1, 1, K, 1, -1, 0 ) + PASSED = ( K .EQ. 0 ) + AUXPASSED = PASSED + IF( IPRINT ) THEN + IF( PASSED ) THEN + WRITE(OUTNUM,*) 'PASSED BLACS_PNUM/BLACS_PCOORD TEST' + ELSE + WRITE(OUTNUM,*) 'FAILED BLACS_PNUM/BLACS_PCOORD TEST' + END IF + WRITE(OUTNUM,*) ' ' + END IF +* +* Test to see if DGSUM2D is repeatable when repeatability flag is set +* Skip test if DGSUM2D is repeatable when repeatability flag is not set +* NOTE: do not change the EPS calculation loop; it is figured in this +* strange way so that it ports across platforms +* + IF( IPRINT ) WRITE(OUTNUM,*) 'RUNNING REPEATABLE SUM TEST' + J = 0 + 12 CONTINUE + PASSED = .TRUE. + START(1) = 1.0D0 + 15 CONTINUE + DEPS = START(1) + START(1) = START(1) / 2.0D0 + STST(1) = 1.0D0 + START(1) + IF (STST(1) .NE. 1.0D0) GOTO 15 +* + START(1) = DEPS / DBLE(NPCOL-1) + IF (MYCOL .EQ. 3) START(1) = 1.0D0 + START(2) = 7.00005D0 * NPCOL + STST(1) = START(1) + STST(2) = START(2) + CALL BLACS_SET(CTXT, 15, J) + CALL DGSUM2D(CTXT, 'a', 'f', 2, 1, STST, 2, -1, 0) + KEEP(1) = STST(1) + KEEP(2) = STST(2) + DO 30 I = 1, 3 +* +* Have a different guy waste time so he enters combine last +* + IF (MYCOL .EQ. I) THEN + DTIME = DWALLTIME00() + 20 CONTINUE + IF (DWALLTIME00() - DTIME .LT. 2.0D0) GOTO 20 + END IF + STST(1) = START(1) + STST(2) = START(2) + CALL DGSUM2D(CTXT, 'a', 'f', 2, 1, STST, 2, -1, 0) + IF ( (KEEP(1).NE.STST(1)) .OR. (KEEP(2).NE.STST(2)) ) + $ PASSED = .FALSE. + 30 CONTINUE + K = 1 + IF (PASSED) K = 0 + CALL IGSUM2D( CTXT, 'a', ' ', 1, 1, K, 1, -1, 0 ) + PASSED = (K .EQ. 0) + IF (J .EQ. 0) THEN + IF (.NOT.PASSED) THEN + J = 1 + GOTO 12 + ELSE IF( IPRINT ) THEN + WRITE(OUTNUM,*) 'SKIPPED REPEATABLE SUM TEST' + WRITE(OUTNUM,*) ' ' + END IF + END IF +* + IF (J .EQ. 1) THEN + AUXPASSED = AUXPASSED .AND. PASSED + IF( IPRINT ) THEN + IF( PASSED ) THEN + WRITE(OUTNUM,*) 'PASSED REPEATABLE SUM TEST' + ELSE + WRITE(OUTNUM,*) 'FAILED REPEATABLE SUM TEST' + END IF + WRITE(OUTNUM,*) ' ' + END IF + END IF +* +* Test BLACS_GRIDMAP: force a column major ordering, starting at an +* arbitrary processor +* + PASSED = .TRUE. + IF( IPRINT ) WRITE(OUTNUM,*) 'RUNNING BLACS_GRIDMAP TEST' + NPROW = 2 + NPCOL = NPROCS / NPROW + DO 40 I = 0, NPROCS-1 + MEM(I+1) = BLACS_PNUM( CTXT, 0, MOD(I+NPCOL, NPROCS) ) + 40 CONTINUE + CALL BLACS_GET( CTXT, 10, CTXT2 ) + CALL BLACS_GRIDMAP( CTXT2, MEM, NPROW, NPROW, NPCOL ) + CALL BLACS_GRIDINFO( CTXT2, NPROW, NPCOL, MYROW, MYCOL ) + PASSED = ( NPROW.EQ.2 .AND. NPCOL.EQ.NPROCS/2 ) +* +* Fan in pids for final check: Note we assume SD/RV working +* + IF( PASSED ) THEN + K = BLACS_PNUM( CTXT2, MYROW, MYCOL ) + IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN + DO 60 J = 0, NPCOL-1 + DO 50 I = 0, NPROW-1 + IF( I.NE.0 .OR. J.NE.0 ) + $ CALL IGERV2D( CTXT2, 1, 1, K, 1, I, J ) + IF ( PASSED ) + $ PASSED = ( K .EQ. BLACS_PNUM(CTXT2, I, J) ) + 50 CONTINUE + 60 CONTINUE + ELSE + CALL IGESD2D( CTXT2, 1, 1, K, 1, 0, 0 ) + END IF + END IF + K = 1 + IF ( PASSED ) K = 0 + CALL IGSUM2D( CTXT, 'a', ' ', 1, 1, K, 1, -1, 0 ) + PASSED = ( K .EQ. 0 ) + AUXPASSED = AUXPASSED .AND. PASSED + IF( IPRINT ) THEN + IF( PASSED ) THEN + WRITE(OUTNUM,*) 'PASSED BLACS_GRIDMAP TEST' + ELSE + WRITE(OUTNUM,*) 'FAILED BLACS_GRIDMAP TEST' + END IF + WRITE(OUTNUM,*) ' ' + END IF +* + IF( IPRINT ) WRITE(OUTNUM,*) 'CALL BLACS_FREEBUFF' + CALL BLACS_FREEBUFF( CTXT, 0 ) + CALL BLACS_FREEBUFF( CTXT, 1 ) + J = 0 + CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL ) + IF( IPRINT ) THEN + WRITE(OUTNUM,*) 'DONE BLACS_FREEBUFF' + WRITE(OUTNUM,*) ' ' + END IF +* +* Make sure barriers don't interfere with each other +* + IF( IPRINT ) WRITE(OUTNUM,*) 'CALL BARRIER' + CALL BLACS_BARRIER(CTXT2, 'A') + CALL BLACS_BARRIER(CTXT2, 'R') + CALL BLACS_BARRIER(CTXT2, 'C') + CALL BLACS_BARRIER(CTXT2, 'R') + CALL BLACS_BARRIER(CTXT2, 'A') + CALL BLACS_BARRIER(CTXT2, 'C') + CALL BLACS_BARRIER(CTXT2, 'C') + CALL BLACS_BARRIER(CTXT2, 'R') + CALL BLACS_BARRIER(CTXT2, 'A') + J = 0 + CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL ) + IF( IPRINT ) THEN + WRITE(OUTNUM,*) 'DONE BARRIER' + WRITE(OUTNUM,*) ' ' + END IF +* +* Ensure contiguous sends are locally-blocking +* + IF( IPRINT ) THEN + WRITE(OUTNUM,*) 'The following tests will hang if your BLACS'// + $ ' are not locally blocking:' + WRITE(OUTNUM,*) 'RUNNING LOCALLY-BLOCKING CONTIGUOUS SEND TEST' + END IF + K = MIN( MEMLEN, 50000 ) +* +* Initialize send buffer +* + DO 70 J = 1, K + MEM(J) = 1 + 70 CONTINUE +* + IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN + CALL IGESD2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 ) + CALL IGESD2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 ) + CALL IGESD2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 ) + CALL IGERV2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 ) + CALL IGERV2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 ) + CALL IGERV2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 ) + ELSE IF( MYROW.EQ.NPROW-1 .AND. MYCOL.EQ.NPCOL-1 ) THEN + CALL IGESD2D( CTXT2, K, 1, MEM, K, 0, 0 ) + CALL IGESD2D( CTXT2, K, 1, MEM, K, 0, 0 ) + CALL IGESD2D( CTXT2, K, 1, MEM, K, 0, 0 ) + CALL IGERV2D( CTXT2, K, 1, MEM, K, 0, 0 ) + CALL IGERV2D( CTXT2, K, 1, MEM, K, 0, 0 ) + CALL IGERV2D( CTXT2, K, 1, MEM, K, 0, 0 ) + END IF + J = 0 + CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL ) + IF( IPRINT ) + $ WRITE(OUTNUM,*) 'PASSED LOCALLY-BLOCKING CONTIGUOUS SEND TEST' +* +* Ensure non-contiguous sends are locally-blocking +* + J = 4 + LDA = K / J + I = MAX( 2, LDA / 4 ) + IF( IPRINT ) + $ WRITE(OUTNUM,*) 'RUNNING LOCALLY-BLOCKING NON-CONTIGUOUS '// + $ 'SEND TEST' + IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN + CALL IGESD2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 ) + CALL IGESD2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 ) + CALL IGESD2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 ) + CALL IGERV2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 ) + CALL IGERV2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 ) + CALL IGERV2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 ) + ELSE IF( MYROW.EQ.NPROW-1 .AND. MYCOL.EQ.NPCOL-1 ) THEN + CALL IGESD2D( CTXT2, I, J, MEM, LDA, 0, 0 ) + CALL IGESD2D( CTXT2, I, J, MEM, LDA, 0, 0 ) + CALL IGESD2D( CTXT2, I, J, MEM, LDA, 0, 0 ) + CALL IGERV2D( CTXT2, I, J, MEM, LDA, 0, 0 ) + CALL IGERV2D( CTXT2, I, J, MEM, LDA, 0, 0 ) + CALL IGERV2D( CTXT2, I, J, MEM, LDA, 0, 0 ) + END IF + CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL ) + IF( IPRINT ) THEN + WRITE(OUTNUM,*)'PASSED LOCALLY-BLOCKING NON-CONTIGUOUS '// + $ 'SEND TEST' + WRITE(OUTNUM,*) ' ' + END IF +* +* Note that we already tested the message ID setting/getting in +* first call to IBTMSGID() +* + IF( IPRINT ) WRITE(OUTNUM,*) 'RUNNING BLACS_SET/BLACS_GET TESTS' + J = 0 + CALL BLACS_SET( CTXT2, 11, 3 ) + CALL BLACS_SET( CTXT2, 12, 2 ) + CALL BLACS_GET( CTXT2, 12, I ) + CALL BLACS_GET( CTXT2, 11, K ) + IF( K.NE.3 ) J = J + 1 + IF( I.NE.2 ) J = J + 1 + CALL BLACS_SET( CTXT2, 13, 3 ) + CALL BLACS_SET( CTXT2, 14, 2 ) + CALL BLACS_GET( CTXT2, 14, I ) + CALL BLACS_GET( CTXT2, 13, K ) + IF( K.NE.3 ) J = J + 1 + IF( I.NE.2 ) J = J + 1 +* +* See if anyone had error, and print result +* + CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL ) + PASSED = (J .EQ. 0) + AUXPASSED = AUXPASSED .AND. PASSED + IF( IPRINT ) THEN + IF( PASSED ) THEN + WRITE(OUTNUM,*) 'PASSED BLACS_SET/BLACS_GET TESTS' + ELSE + WRITE(OUTNUM,*) 'FAILED BLACS_SET/BLACS_GET TESTS' + END IF + WRITE(OUTNUM,*) ' ' + END IF +* + IF( IPRINT ) WRITE(OUTNUM,*) 'CALL BLACS_GRIDEXIT' + CALL BLACS_GRIDEXIT(CTXT) + CALL BLACS_GRIDEXIT(CTXT2) + IF( IPRINT ) THEN + WRITE(OUTNUM,*) 'DONE BLACS_GRIDEXIT' + WRITE(OUTNUM,*) ' ' + END IF +* + 100 CONTINUE +* + PASSED = ALLPASS(AUXPASSED) + IF( IPRINT ) THEN + WRITE(OUTNUM,*) 'The final auxiliary test is for BLACS_ABORT.' + WRITE(OUTNUM,*) 'Immediately after this message, all '// + $ 'processes should be killed.' + WRITE(OUTNUM,*) 'If processes survive the call, your BLACS_'// + $ 'ABORT is incorrect.' + END IF + CALL BLACS_PINFO( I, NPROCS ) + CALL BLACS_GET( 0, 0, CTXT ) + CALL BLACS_GRIDINIT( CTXT, 'r', 1, NPROCS ) + CALL BLACS_BARRIER(CTXT, 'A') + CALL BLACS_GRIDINFO( CTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Test BLACS_ABORT +* + IF( MYROW.EQ.NPROW/2 .AND. MYCOL.EQ.NPCOL/2 ) THEN + CALL BLACS_ABORT( CTXT, -1 ) +* +* Other procs try to cause a hang: should be killed by BLACS_ABORT +* + ELSE + I = 1 +110 CONTINUE + I = I + 3 + I = I - 2 + I = I - 1 + IF( I.EQ.1 ) GOTO 110 + end if +* + 1000 FORMAT('AUXILIARY TESTS: BEGIN.') + RETURN + END +* + SUBROUTINE BTTRANSCHAR(TRANSTO, N, CMEM, IMEM) + CHARACTER TRANSTO + INTEGER N + CHARACTER*1 CMEM(N) + INTEGER IMEM(N) + INTEGER I +* + IF( TRANSTO .EQ. 'I' ) THEN + DO 10 I = 1, N + IMEM(I) = ICHAR( CMEM(I) ) + 10 CONTINUE + ELSE + DO 20 I = 1, N + CMEM(I) = CHAR( IMEM(I) ) + 20 CONTINUE + END IF + RETURN + END +* + SUBROUTINE BTINFO( TEST, MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, + $ CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP, + $ NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR, + $ TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, + $ LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR, + $ CDESTPTR, PPTR, QPTR ) +* +* .. Scalar Arguments .. + CHARACTER*1 TEST + INTEGER CDESTPTR, CMEMLEN, CMEMUSED, CSRCPTR, DIAGPTR, LDDPTR, + $ LDIPTR, LDSPTR, MEMLEN, MEMUSED, MPTR, NGRID, NMAT, NOP, + $ NPTR, NSCOPE, NSHAPE, NSRC, NTOP, OPPTR, OUTNUM, PPTR, + $ QPTR, RDESTPTR, RSRCPTR, SCOPEPTR, TCOH, TOPPTR, TREP, + $ UPLOPTR +* .. +* .. Array Arguments .. + CHARACTER*1 CMEM(CMEMLEN) + INTEGER MEM(MEMLEN) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTMSGID, IBTSIZEOF + EXTERNAL IBTMYPROC, IBTMSGID, IBTSIZEOF +* .. +* .. Local Scalars .. + INTEGER IAM, ISIZE, DSIZE +* .. +* .. Local Arrays .. + INTEGER ITMP(2) +* .. +* .. Executable Statements .. +* + IAM = IBTMYPROC() + IF( IAM .EQ. 0 ) THEN + IF( TEST .EQ. 'S' ) THEN + CALL RDSDRV( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, + $ OUTNUM ) + ELSE IF( TEST .EQ. 'B' ) THEN + CALL RDBSBR( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, + $ OUTNUM ) + ELSE + CALL RDCOMB( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, + $ OUTNUM ) + END IF + ITMP(1) = MEMUSED + ITMP(2) = CMEMUSED + CALL BTSEND( 3, 2, ITMP, -1, IBTMSGID()+3 ) + IF( MEMLEN .GE. MEMUSED + CMEMUSED ) THEN + CALL BTTRANSCHAR( 'I', CMEMUSED, CMEM, MEM(MEMUSED+1) ) + ELSE + ISIZE = IBTSIZEOF('I') + DSIZE = IBTSIZEOF('D') + WRITE(OUTNUM,1000) ( (MEMUSED+CMEMUSED)*ISIZE + DSIZE-1 ) + $ / DSIZE + CALL BLACS_ABORT(-1, -1) + END IF + CALL BTSEND( 3, MEMUSED+CMEMUSED, MEM, -1, IBTMSGID()+4 ) + ELSE + CALL BTRECV( 3, 2, ITMP, 0, IBTMSGID()+3 ) + MEMUSED = ITMP(1) + CMEMUSED = ITMP(2) + IF( MEMLEN .GE. MEMUSED + CMEMUSED ) THEN + CALL BTRECV( 3, MEMUSED+CMEMUSED, MEM, 0, IBTMSGID()+4 ) + CALL BTTRANSCHAR( 'C', CMEMUSED, CMEM, MEM(MEMUSED+1) ) + ELSE + ISIZE = IBTSIZEOF('I') + DSIZE = IBTSIZEOF('D') + WRITE(OUTNUM,1000) ( (MEMUSED+CMEMUSED)*ISIZE + DSIZE-1 ) + $ / DSIZE + CALL BLACS_ABORT(-1, -1) + END IF + END IF + CALL BTUNPACK( TEST, MEM, MEMUSED, NOP, NSCOPE, TREP, TCOH, NTOP, + $ NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR, TOPPTR, + $ UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR, + $ LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR, CDESTPTR, PPTR, + $ QPTR) +* + 1000 FORMAT('MEM array too short to pack CMEM; increase to at least', + $ I7) +* + RETURN +* +* End BTINFO +* + END +* + SUBROUTINE RDBTIN( TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, NPREC, + $ PREC, VERB, OUTNUM ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX + INTEGER NPREC, OUTNUM, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 PREC(*) +* .. +* +* Purpose +* ======= +* RDBTIN: Read and process the top-level input file BT.dat. +* +* Arguments +* ========= +* TESTSDRV (output) LOGICAL +* Run any point-to-point tests? +* +* TESTBSBR (output) LOGICAL +* Run any broadcast tests? +* +* TESTCOMB (output) LOGICAL +* Run any combine-operation tests (e.g. MAX) +* +* TESTAUX (output) LOGICAL +* Run any auxiliary tests? +* +* NPREC (output) INTEGER +* Number of different precisions to test. (up to 5, as determined +* by the parameter PRECMAX down in the code.) +* +* PREC (output) CHARACTER*1 array, dimension 5 +* Prefix letter of each precision to test, from the set +* {'C', 'D', 'I', 'S', 'Z'} +* +* VERB (output) INTEGER +* Output verbosity for this test run. +* 0 = Print only "BEGIN [SDRV/BSBR/COMB]", followed by PASSED +* or FAILED message +* 1 = Same as 0, but also prints out header explaining all tests +* to be run. +* 2 = Prints out info before and after every individual test. +* +* OUTNUM (output) INTEGER +* Unit number for output file. +* ====================================================================== +* +* +* .. Parameters .. + INTEGER PRECMAX, VERBMAX, IN + PARAMETER ( PRECMAX = 5, VERBMAX = 2, IN = 11 ) +* .. +* .. Local Scalars .. + INTEGER I + CHARACTER*1 CH + LOGICAL READERROR +* .. +* .. Local Arrays .. + CHARACTER*80 HEADER, OUTNAME +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements +* +* Open and read the file blacstest.dat. Expected format is +* ----- +* 'One line of free text intended as a comment for each test run' +* integer Unit number of output file +* string Name of output file (ignored if unit = 6) +* {'T'|'F'} Run any point to point tests? +* {'T'|'F'} Run any broadcast tests? +* {'T'|'F'} Run any combine-operator tests? +* {'T'|'F'} Run the auxiliary tests? +* integer Number of precisions to test - up to 99 +* array of CHAR*1's Specific precisions to test +* integer Output verb (1-n, n=most verbose) +* integer Number of nodes required by largest test case +* ----- +* Note that the comments to the right of each line are present +* in the sample blacstest.dat file included with this +* distribution, but they are not required. +* +* The array of CHAR*1's is expected to have length equal to the +* integer in the previous line - if it is shorter, problems may +* occur later; if it is longer, the trailing elements will just +* be ignored. The verb is expected to be an integer +* between 1 and n inclusive and will be set to 1 if outside +* this range. +* +* Only process 0 should be calling this routine +* + READERROR = .FALSE. + OPEN( UNIT = IN, FILE = 'bt.dat', STATUS = 'OLD' ) + READ(IN, *) HEADER + READ(IN, *) OUTNUM + READ(IN, *) OUTNAME +* +* Open and prepare output file +* + IF( OUTNUM.NE.6 .AND. OUTNUM.NE.0 ) + $ OPEN( UNIT = OUTNUM, FILE = OUTNAME, STATUS = 'UNKNOWN' ) + WRITE(OUTNUM, *) HEADER +* +* Determine which tests to run +* + READ(IN, *) CH + IF( LSAME(CH, 'T') ) THEN + TESTSDRV = .TRUE. + ELSE IF( LSAME(CH, 'F') ) THEN + TESTSDRV = .FALSE. + ELSE + WRITE(OUTNUM, 1000) 'SDRV', CH + READERROR = .TRUE. + END IF +* + READ(IN, *) CH + IF( LSAME(CH, 'T') ) THEN + TESTBSBR = .TRUE. + ELSE IF(LSAME( CH, 'F') ) THEN + TESTBSBR = .FALSE. + ELSE + WRITE(OUTNUM, 1000) 'BSBR', CH + READERROR = .TRUE. + END IF +* + READ(IN, *) CH + IF( LSAME(CH, 'T') ) THEN + TESTCOMB = .TRUE. + ELSE IF( LSAME(CH, 'F') ) THEN + TESTCOMB = .FALSE. + ELSE + WRITE(OUTNUM, 1000) 'COMB', CH + READERROR = .TRUE. + END IF +* + READ(IN, *) CH + IF( LSAME(CH, 'T') ) THEN + TESTAUX = .TRUE. + ELSE IF( LSAME(CH, 'F') ) THEN + TESTAUX = .FALSE. + ELSE + WRITE(OUTNUM, 1000) 'AUX ', CH + READERROR = .TRUE. + END IF +* +* Get # of precisions, and precisions to test +* + READ(IN, *) NPREC + IF( NPREC .LT. 0 ) THEN + NPREC = 0 + ELSE IF( NPREC. GT. PRECMAX ) THEN + WRITE(OUTNUM, 2000) NPREC, PRECMAX, PRECMAX + NPREC = PRECMAX + END IF +* + READ(IN, *) ( PREC(I), I = 1, NPREC ) + DO 100 I = 1, NPREC + IF( LSAME(PREC(I), 'C') ) THEN + PREC(I) = 'C' + ELSE IF( LSAME(PREC(I), 'D') ) THEN + PREC(I) = 'D' + ELSE IF( LSAME(PREC(I), 'I') ) THEN + PREC(I) = 'I' + ELSE IF( LSAME(PREC(I), 'S') ) THEN + PREC(I) = 'S' + ELSE IF( LSAME(PREC(I), 'Z') ) THEN + PREC(I) = 'Z' + ELSE + WRITE(OUTNUM, 3000) PREC(I) + READERROR = .TRUE. + END IF + 100 CONTINUE +* + READ(IN, *) VERB +* + IF( VERB .GT. VERBMAX ) THEN + WRITE(OUTNUM, 4000) VERB, VERBMAX, VERBMAX + VERB = VERBMAX + ELSE IF( VERB .LT. 0 ) THEN + WRITE(OUTNUM, 5000) VERB + VERB = 0 + END IF +* +* Abort if there was a fatal error +* + IF( READERROR ) THEN + WRITE(OUTNUM, 6000) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM ) + STOP + END IF +* + 1000 FORMAT( 'INVALID CHARACTER FOR ',A4,' TESTS ''', A1, + $ ''' (EXPECTED T/F)' ) + 2000 FORMAT( 'NUMBER OF PRECISIONS ', I6, ' GREATER THAN ', I6, + $ ' - SETTING TO ', I6, '.') + 3000 FORMAT( 'UNRECOGNIZABLE PRECISION ENTRY ''', A1, + $ ''' - EXPECTED ''C'', ''D'', ''I'', ''S'', OR ''Z''.') + 4000 FORMAT( 'VERBOSITY ', I4, ' GREATER THAN ',I4, + $ ' - SETTING TO ',I4,'.') + 5000 FORMAT( 'VERBOSITY ', I4, ' LESS THAN 0 - SETTING TO 0' ) + 6000 FORMAT( 'FATAL INPUT FILE ERROR - ABORTING RUN.' ) +* + RETURN +* +* End of RDBTIN +* + END +* + INTEGER FUNCTION IBTMSGID() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* PURPOSE +* ======= +* IBTMSGID : returns a ID for tester communication. +* + INTEGER MINID + INTEGER ITMP(2) + SAVE MINID + DATA MINID /-1/ +* +* On first call, reserve 1st 1000 IDs for tester use +* + IF (MINID .EQ. -1) THEN + CALL BLACS_GET( -1, 1, ITMP ) + MINID = ITMP(1) + ITMP(1) = ITMP(1) + 1000 + CALL BLACS_SET( -1, 1, ITMP ) + END IF +* +* return the minimum allowable ID +* + IBTMSGID = MINID +* + RETURN + END +* + SUBROUTINE BTUNPACK(TEST, MEM, MEMLEN, NOP, NSCOPE, TREP, TCOH, + $ NTOP, NSHAPE, NMAT, NSRC, NGRID, OPPTR, + $ SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR, + $ NPTR, LDSPTR, LDDPTR, LDIPTR, RSRCPTR, + $ CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 TEST + INTEGER CDESTPTR, CSRCPTR, DIAGPTR, LDDPTR, LDIPTR, LDSPTR, + $ MEMLEN, MPTR, NGRID, NMAT, NOP, NPTR, NSCOPE, NSHAPE, + $ NSRC, NTOP, OPPTR, PPTR, QPTR, RDESTPTR, RSRCPTR, + $ SCOPEPTR, TCOH, TOPPTR, TREP, UPLOPTR +* .. +* .. Array Arguments .. + INTEGER MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* BTUNPACK: Figure pointers into MEM where the various input values +* are stored. +* +* Arguments +* ========= +* TEST (input) CHARACTER*1 +* The test we're unpacking for: +* = 'S' : SDRV test +* = 'B' : BSBR test +* = 'C' : Combine test +* +* MEM (input) INTEGER array of dimension MEMLEN +* Memory containing values and number of items. +* +* MEMLEN (input/output) INTEGER +* The number of elements that are used in MEM. +* +* . +* . +* . +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER NDEST, NLDI +* .. +* .. Executable Statements .. +* +* Test is SDRV +* + IF( TEST .EQ. 'S' ) THEN + NOP = 0 + NSHAPE = MEM(MEMLEN-3) + NSCOPE = 0 + TREP = 0 + TCOH = 0 + NTOP = 0 + NMAT = MEM(MEMLEN-2) + NLDI = 0 + NSRC = MEM(MEMLEN-1) + NDEST = NSRC + NGRID = MEM(MEMLEN) + MEMLEN = MEMLEN - 3 +* +* Test is BSBR +* + ELSE IF ( TEST .EQ. 'B' ) THEN + NOP = 0 + NSCOPE = MEM(MEMLEN-5) + TREP = 0 + TCOH = 0 + NTOP = MEM(MEMLEN-4) + NSHAPE = MEM(MEMLEN-3) + NMAT = MEM(MEMLEN-2) + NLDI = 0 + NSRC = MEM(MEMLEN-1) + NDEST = 0 + NGRID = MEM(MEMLEN) + MEMLEN = MEMLEN - 5 +* +* Test is COMB +* + ELSE + NOP = MEM(MEMLEN-7) + NSCOPE = MEM(MEMLEN-6) + TREP = MEM(MEMLEN-5) + TCOH = MEM(MEMLEN-4) + NTOP = MEM(MEMLEN-3) + NSHAPE = 0 + NMAT = MEM(MEMLEN-2) + NLDI = NMAT + NSRC = 0 + NDEST = MEM(MEMLEN-1) + NGRID = MEM(MEMLEN) + MEMLEN = MEMLEN - 6 + END IF + OPPTR = 1 + SCOPEPTR = OPPTR + NOP + TOPPTR = SCOPEPTR + NSCOPE + UPLOPTR = TOPPTR + NTOP + DIAGPTR = UPLOPTR + NSHAPE + MPTR = 1 + NPTR = MPTR + NMAT + LDSPTR = NPTR + NMAT + LDDPTR = LDSPTR + NMAT + LDIPTR = LDDPTR + NMAT + RSRCPTR = LDIPTR + NLDI + CSRCPTR = RSRCPTR + NSRC + RDESTPTR = CSRCPTR + NSRC + CDESTPTR = RDESTPTR + NDEST + PPTR = CDESTPTR + NDEST + QPTR = PPTR + NGRID + IF( NSRC .EQ. 0 ) NSRC = NDEST +* + RETURN +* +* End of BTUNPACK +* + END +* + INTEGER FUNCTION SAFEINDEX(INDX, SIZE1, SIZE2) +* +* .. Scalar Arguments .. + INTEGER INDX, SIZE1, SIZE2 +* .. +* +* If you have an array with elements of SIZE1 bytes, of which you +* have used INDX-1 elements, returns the index necessary to keep it +* on a SIZE2 boundary (assuming it was SIZE2 aligned in the first place). +* +* .. Local scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Take into account that Fortran starts arrays at 1, not 0 +* + I = INDX - 1 + 10 CONTINUE + IF( MOD(I*SIZE1, SIZE2) .EQ. 0 ) GOTO 20 + I = I + 1 + GOTO 10 + 20 CONTINUE +* + SAFEINDEX = I + 1 +* + RETURN + END +* +* + SUBROUTINE RDSDRV( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, + $ OUTNUM ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM +* .. +* .. Array Arguments .. + CHARACTER*1 CMEM(CMEMLEN) + INTEGER MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* RDSDRV: Read and process the input file SDRV.dat. +* +* Arguments +* ========= +* MEMUSED (output) INTEGER +* Number of elements in MEM that this subroutine ends up using. +* +* MEM (output) INTEGER array of dimension memlen +* On output, holds information read in from sdrv.dat. +* +* MEMLEN (input) INTEGER +* Number of elements of MEM that this subroutine +* may safely write into. +* +* CMEMUSED (output) INTEGER +* Number of elements in CMEM that this subroutine ends up using. +* +* CMEM (output) CHARACTER*1 array of dimension cmemlen +* On output, holds the values for UPLO and DIAG. +* +* CMEMLEN (input) INTEGER +* Number of elements of CMEM that this subroutine +* may safely write into. +* +* OUTNUM (input) INTEGER +* Unit number of the output file. +* +* ================================================================= +* +* .. Parameters .. + INTEGER SDIN + PARAMETER( SDIN = 12 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Local Scalars .. + INTEGER NSHAPE, NMAT, NSRC, NGRID, I, J + INTEGER UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR, RSRCPTR + INTEGER CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR +* .. +* .. Executable Statements +* +* Open and read the file sdrv.dat. The expected format is +* below. +* +*------ +*integer number of shapes of the matrix +*array of CHAR*1's UPLO +*array of CHAR*1's DIAG: unit diagonal or not? +*integer number of nmat +*array of integers M: number of rows in matrix +*array of integers N: number of columns in matrix +*integer LDA: leading dimension on source proc +*integer LDA: leading dimension on dest proc +*integer number of source/dest pairs +*array of integers RSRC: process row of message source +*array of integers CSRC: process column of msg. src. +*array of integers RDEST: process row of msg. dest. +*array of integers CDEST: process column of msg. dest. +*integer Number of grids +*array of integers NPROW: number of rows in process grid +*array of integers NPCOL: number of col's in proc. grid +*------ +* note: UPLO stands for 'upper or lower trapezoidal or general +* rectangular.' +* note: the text descriptions as shown above are present in +* the sample sdrv.dat included with this distribution, +* but are not required. +* +* Read input file +* + MEMUSED = 1 + CMEMUSED = 1 + OPEN(UNIT = SDIN, FILE = 'sdrv.dat', STATUS = 'OLD') +* +* Read in number of shapes, and values of UPLO and DIAG +* + READ(SDIN, *) NSHAPE + UPLOPTR = CMEMUSED + DIAGPTR = UPLOPTR + NSHAPE + CMEMUSED = DIAGPTR + NSHAPE + IF ( CMEMUSED .GT. CMEMLEN ) THEN + WRITE(OUTNUM, 1000) CMEMLEN, NSHAPE, 'MATRIX SHAPES.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NSHAPE .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'MATRIX SHAPE.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF +* +* Read in, upcase, and fatal error if UPLO/DIAG not recognized +* + READ(SDIN, *) ( CMEM(UPLOPTR+I), I = 0, NSHAPE-1 ) + DO 30 I = 0, NSHAPE-1 + IF( LSAME(CMEM(UPLOPTR+I), 'G') ) THEN + CMEM(UPLOPTR+I) = 'G' + ELSE IF( LSAME(CMEM(UPLOPTR+I), 'U') ) THEN + CMEM(UPLOPTR+I) = 'U' + ELSE IF( LSAME(CMEM(UPLOPTR+I), 'L') ) THEN + CMEM(UPLOPTR+I) = 'L' + ELSE + WRITE(OUTNUM, 3000) 'UPLO ', CMEM(UPLOPTR+I) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + 30 CONTINUE +* + READ(SDIN, *) ( CMEM(DIAGPTR+I), I = 0, NSHAPE-1 ) + DO 40 I = 0, NSHAPE-1 + IF( CMEM(UPLOPTR+I) .NE. 'G' ) THEN + IF( LSAME(CMEM(DIAGPTR+I), 'U') ) THEN + CMEM( DIAGPTR+I ) = 'U' + ELSE IF( LSAME(CMEM(DIAGPTR+I), 'N') ) THEN + CMEM(DIAGPTR+I) = 'N' + ELSE + WRITE(OUTNUM, 3000) 'DIAG ', CMEM(DIAGPTR+I) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + END IF + 40 CONTINUE +* +* Read in number of matrices, and values for M, N, LDASRC, and LDADEST +* + READ(SDIN, *) NMAT + MPTR = MEMUSED + NPTR = MPTR + NMAT + LDSPTR = NPTR + NMAT + LDDPTR = LDSPTR + NMAT + MEMUSED = LDDPTR + NMAT + IF( MEMUSED .GT. MEMLEN ) THEN + WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'MATRICES.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NMAT .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'MATRIX.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + READ(SDIN, *) ( MEM( MPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( NPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( LDSPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( LDDPTR+I ), I = 0, NMAT-1 ) +* +* Make sure matrix values are legal +* + CALL CHKMATDAT( OUTNUM, 'SDRV.dat', .FALSE., NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), MEM(LDDPTR) ) +* +* Read in number of src/dest pairs, and values of src/dest +* + READ(SDIN, *) NSRC + RSRCPTR = MEMUSED + CSRCPTR = RSRCPTR + NSRC + RDESTPTR = CSRCPTR + NSRC + CDESTPTR = RDESTPTR + NSRC + MEMUSED = CDESTPTR + NSRC + IF( MEMUSED .GT. MEMLEN ) THEN + WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'SRC/DEST.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NSRC .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'SRC/DEST.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + READ(SDIN, *) ( MEM(RSRCPTR+I), I = 0, NSRC-1 ) + READ(SDIN, *) ( MEM(CSRCPTR+I), I = 0, NSRC-1 ) + READ(SDIN, *) ( MEM(RDESTPTR+I), I = 0, NSRC-1 ) + READ(SDIN, *) ( MEM(CDESTPTR+I), I = 0, NSRC-1 ) +* +* Read in number of grids pairs, and values of P (process rows) and +* Q (process columns) +* + READ(SDIN, *) NGRID + PPTR = MEMUSED + QPTR = PPTR + NGRID + MEMUSED = QPTR + NGRID + IF( MEMUSED .GT. MEMLEN ) THEN + WRITE(OUTNUM, 1000) MEMLEN, NGRID, 'PROCESS GRIDS.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NGRID .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'PROCESS GRID' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM ) + STOP + END IF +* + READ(SDIN, *) ( MEM(PPTR+I), I = 0, NGRID-1 ) + READ(SDIN, *) ( MEM(QPTR+I), I = 0, NGRID-1 ) + IF( SDIN .NE. 6 .AND. SDIN .NE. 0 ) CLOSE( SDIN ) +* +* Fatal error if we've got an illegal grid +* + DO 70 J = 0, NGRID-1 + IF( MEM(PPTR+J).LT.1 .OR. MEM(QPTR+J).LT.1 ) THEN + WRITE(OUTNUM, 4000) MEM(PPTR+J), MEM(QPTR+J) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + 70 CONTINUE +* +* Prepare output variables +* + MEM(MEMUSED) = NSHAPE + MEM(MEMUSED+1) = NMAT + MEM(MEMUSED+2) = NSRC + MEM(MEMUSED+3) = NGRID + MEMUSED = MEMUSED + 3 + CMEMUSED = CMEMUSED - 1 +* + 1000 FORMAT('Mem too short (',I4,') to handle',I4,' ',A20) + 2000 FORMAT('Must have at least one ',A20) + 3000 FORMAT('UNRECOGNIZABLE ',A5,' ''', A1, '''.') + 4000 FORMAT('Illegal process grid: {',I3,',',I3,'}.') +* + RETURN +* +* End of RDSDRV. +* + END +* + SUBROUTINE CHKMATDAT( NOUT, INFILE, TSTFLAG, NMAT, M0, N0, + $ LDAS0, LDAD0, LDI0 ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + LOGICAL TSTFLAG + INTEGER NOUT, NMAT +* .. +* .. Array Arguments .. + CHARACTER*8 INFILE + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) +* .. +* Purpose +* ======= +* CHKMATDAT: Checks that matrix data is correct. +* +* Arguments +* ========= +* NOUT (input) INTEGER +* The device number to write output to. +* +* INFILE (input) CHARACTER*8 +* The name of the input file where matrix values came from. +* +* TSTFLAG (input) LOGICAL +* Whether to test RCFLAG (LDI) values or not. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* +* ==================================================================== +* +* .. Local Scalars .. + LOGICAL MATOK + INTEGER I +* .. +* .. Executable Statements .. + MATOK = .TRUE. + DO 10 I = 1, NMAT + IF( M0(I) .LT. 0 ) THEN + WRITE(NOUT,1000) INFILE, 'M', M0(I) + MATOK = .FALSE. + ELSE IF( N0(I) .LT. 0 ) THEN + WRITE(NOUT,1000) INFILE, 'N', N0(I) + MATOK = .FALSE. + ELSE IF( LDAS0(I) .LT. M0(I) ) THEN + WRITE(NOUT,2000) INFILE, 'LDASRC', LDAS0(I), M0(I) + MATOK = .FALSE. + ELSE IF( LDAD0(I) .LT. M0(I) ) THEN + WRITE(NOUT,2000) INFILE, 'LDADST', LDAD0(I), M0(I) + MATOK = .FALSE. + ELSE IF( TSTFLAG ) THEN + IF( (LDI0(I).LT.M0(I)) .AND. (LDI0(I).NE.-1) ) THEN + WRITE(NOUT,2000) INFILE, 'RCFLAG', LDI0(I), M0(I) + MATOK = .FALSE. + END IF + END IF + 10 CONTINUE +* + IF( .NOT.MATOK ) THEN + IF( NOUT .NE. 6 .AND. NOUT .NE. 0 ) CLOSE(NOUT) + CALL BLACS_ABORT(-1, 1) + END IF +* + 1000 FORMAT(A8,' INPUT ERROR: Illegal ',A1,'; value=',I6,'.') + 2000 FORMAT(A8,' INPUT ERROR: Illegal ',A6,'; value=',I6,', but M=',I6) +* + RETURN + END +* + LOGICAL FUNCTION ALLPASS( THISTEST ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + LOGICAL THISTEST +* .. +* Purpose +* ======= +* ALLPASS: Returns whether all tests have passed so far. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL PASSHIST +* .. +* .. Save Statement .. + SAVE PASSHIST +* .. +* .. Data Statements .. + DATA PASSHIST /.TRUE./ +* .. +* .. Executable Statements .. + PASSHIST = (PASSHIST .AND. THISTEST) + ALLPASS = PASSHIST +* + RETURN + END +* + SUBROUTINE RDBSBR( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, + $ OUTNUM ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM +* .. +* .. Array Arguments .. + CHARACTER*1 CMEM(CMEMLEN) + INTEGER MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* RDBSBR: Read and process the input file BSBR.dat. +* +* Arguments +* ========= +* MEMUSED (output) INTEGER +* Number of elements in MEM that this subroutine ends up using. +* +* MEM (output) INTEGER array of dimension memlen +* On output, holds information read in from sdrv.dat. +* +* MEMLEN (input) INTEGER +* Number of elements of MEM that this subroutine +* may safely write into. +* +* CMEMUSED (output) INTEGER +* Number of elements in CMEM that this subroutine ends up using. +* +* CMEM (output) CHARACTER*1 array of dimension cmemlen +* On output, holds the values for UPLO and DIAG. +* +* CMEMLEN (input) INTEGER +* Number of elements of CMEM that this subroutine +* may safely write into. +* +* OUTNUM (input) INTEGER +* Unit number of the output file. +* +* ================================================================= +* +* .. Parameters .. + INTEGER SDIN + PARAMETER( SDIN = 12 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Local Scalars .. + INTEGER NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID, I, J + INTEGER SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR + INTEGER LDSPTR, LDDPTR, RSRCPTR, CSRCPTR, PPTR, QPTR +* .. +* .. Executable Statements +* +* Open and read the file bsbr.dat. The expected format is +* below. +* +*------ +*integer Number of scopes +*array of CHAR*1's Values for Scopes +*integer Number of topologies +*array of CHAR*1's Values for TOP +*integer number of shapes of the matrix +*array of CHAR*1's UPLO +*array of CHAR*1's DIAG: unit diagonal or not? +*integer number of nmat +*array of integers M: number of rows in matrix +*array of integers N: number of columns in matrix +*integer LDA: leading dimension on source proc +*integer LDA: leading dimension on dest proc +*integer number of source/dest pairs +*array of integers RSRC: process row of message source +*array of integers CSRC: process column of msg. src. +*integer Number of grids +*array of integers NPROW: number of rows in process grid +*array of integers NPCOL: number of col's in proc. grid +*------ +* note: UPLO stands for 'upper or lower trapezoidal or general +* rectangular.' +* note: the text descriptions as shown above are present in +* the sample bsbr.dat included with this distribution, +* but are not required. +* +* Read input file +* + MEMUSED = 1 + CMEMUSED = 1 + OPEN(UNIT = SDIN, FILE = 'bsbr.dat', STATUS = 'OLD') +* +* Read in scopes and topologies +* + READ(SDIN, *) NSCOPE + SCOPEPTR = CMEMUSED + CMEMUSED = SCOPEPTR + NSCOPE + IF ( CMEMUSED .GT. CMEMLEN ) THEN + WRITE(OUTNUM, 1000) CMEMLEN, NSCOPE, 'SCOPES.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NSCOPE .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'SCOPE.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF +* + READ(SDIN, *) ( CMEM(SCOPEPTR+I), I = 0, NSCOPE-1 ) + DO 20 I = 0, NSCOPE-1 + IF( LSAME(CMEM(SCOPEPTR+I), 'R') ) THEN + CMEM(SCOPEPTR+I) = 'R' + ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'C') ) THEN + CMEM(SCOPEPTR+I) = 'C' + ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'A') ) THEN + CMEM(SCOPEPTR+I) = 'A' + ELSE + WRITE(OUTNUM, 3000) 'SCOPE', CMEM(SCOPEPTR+I) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + 20 CONTINUE +* + READ(SDIN, *) NTOP + TOPPTR = CMEMUSED + CMEMUSED = TOPPTR + NTOP + IF ( CMEMUSED .GT. CMEMLEN ) THEN + WRITE(OUTNUM, 1000) CMEMLEN, NTOP, 'TOPOLOGIES.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NTOP .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'TOPOLOGY.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + READ(SDIN, *) ( CMEM(TOPPTR+I), I = 0, NTOP-1 ) +* +* +* Read in number of shapes, and values of UPLO and DIAG +* + READ(SDIN, *) NSHAPE + UPLOPTR = CMEMUSED + DIAGPTR = UPLOPTR + NSHAPE + CMEMUSED = DIAGPTR + NSHAPE + IF ( CMEMUSED .GT. CMEMLEN ) THEN + WRITE(OUTNUM, 1000) CMEMLEN, NSHAPE, 'MATRIX SHAPES.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NSHAPE .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'MATRIX SHAPE.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF +* +* Read in, upcase, and fatal error if UPLO/DIAG not recognized +* + READ(SDIN, *) ( CMEM(UPLOPTR+I), I = 0, NSHAPE-1 ) + DO 30 I = 0, NSHAPE-1 + IF( LSAME(CMEM(UPLOPTR+I), 'G') ) THEN + CMEM(UPLOPTR+I) = 'G' + ELSE IF( LSAME(CMEM(UPLOPTR+I), 'U') ) THEN + CMEM(UPLOPTR+I) = 'U' + ELSE IF( LSAME(CMEM(UPLOPTR+I), 'L') ) THEN + CMEM(UPLOPTR+I) = 'L' + ELSE + WRITE(OUTNUM, 3000) 'UPLO ', CMEM(UPLOPTR+I) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + 30 CONTINUE +* + READ(SDIN, *) ( CMEM(DIAGPTR+I), I = 0, NSHAPE-1 ) + DO 40 I = 0, NSHAPE-1 + IF( CMEM(UPLOPTR+I) .NE. 'G' ) THEN + IF( LSAME(CMEM(DIAGPTR+I), 'U') ) THEN + CMEM( DIAGPTR+I ) = 'U' + ELSE IF( LSAME(CMEM(DIAGPTR+I), 'N') ) THEN + CMEM(DIAGPTR+I) = 'N' + ELSE + WRITE(OUTNUM, 3000) 'DIAG ', CMEM(DIAGPTR+I) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + END IF + 40 CONTINUE +* +* Read in number of matrices, and values for M, N, LDASRC, and LDADEST +* + READ(SDIN, *) NMAT + MPTR = MEMUSED + NPTR = MPTR + NMAT + LDSPTR = NPTR + NMAT + LDDPTR = LDSPTR + NMAT + MEMUSED = LDDPTR + NMAT + IF( MEMUSED .GT. MEMLEN ) THEN + WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'MATRICES.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NMAT .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'MATRIX.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + READ(SDIN, *) ( MEM( MPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( NPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( LDSPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( LDDPTR+I ), I = 0, NMAT-1 ) +* +* Make sure matrix values are legal +* + CALL CHKMATDAT( OUTNUM, 'BSBR.dat', .FALSE., NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), MEM(LDDPTR) ) +* +* Read in number of src pairs, and values of src +* + READ(SDIN, *) NSRC + RSRCPTR = MEMUSED + CSRCPTR = RSRCPTR + NSRC + MEMUSED = CSRCPTR + NSRC + IF( MEMUSED .GT. MEMLEN ) THEN + WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'SRC.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NSRC .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'SRC.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + READ(SDIN, *) ( MEM(RSRCPTR+I), I = 0, NSRC-1 ) + READ(SDIN, *) ( MEM(CSRCPTR+I), I = 0, NSRC-1 ) +* +* Read in number of grids pairs, and values of P (process rows) and +* Q (process columns) +* + READ(SDIN, *) NGRID + PPTR = MEMUSED + QPTR = PPTR + NGRID + MEMUSED = QPTR + NGRID + IF( MEMUSED .GT. MEMLEN ) THEN + WRITE(OUTNUM, 1000) MEMLEN, NGRID, 'PROCESS GRIDS.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NGRID .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'PROCESS GRID' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM ) + STOP + END IF +* + READ(SDIN, *) ( MEM(PPTR+I), I = 0, NGRID-1 ) + READ(SDIN, *) ( MEM(QPTR+I), I = 0, NGRID-1 ) + IF( SDIN .NE. 6 .AND. SDIN .NE. 0 ) CLOSE( SDIN ) +* +* Fatal error if we've got an illegal grid +* + DO 70 J = 0, NGRID-1 + IF( MEM(PPTR+J).LT.1 .OR. MEM(QPTR+J).LT.1 ) THEN + WRITE(OUTNUM, 4000) MEM(PPTR+J), MEM(QPTR+J) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + 70 CONTINUE +* +* Prepare output variables +* + MEM(MEMUSED) = NSCOPE + MEM(MEMUSED+1) = NTOP + MEM(MEMUSED+2) = NSHAPE + MEM(MEMUSED+3) = NMAT + MEM(MEMUSED+4) = NSRC + MEM(MEMUSED+5) = NGRID + MEMUSED = MEMUSED + 5 + CMEMUSED = CMEMUSED - 1 +* + 1000 FORMAT('Mem too short (',I4,') to handle',I4,' ',A20) + 2000 FORMAT('Must have at least one ',A20) + 3000 FORMAT('UNRECOGNIZABLE ',A5,' ''', A1, '''.') + 4000 FORMAT('Illegal process grid: {',I3,',',I3,'}.') +* + RETURN +* +* End of RDBSBR. +* + END +* +* + SUBROUTINE ISDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, + $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, + $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC) + INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*) + INTEGER MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ITESTSDRV: Test integer send/recv +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) INTEGER array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL ITRSD2D, IGESD2D, ITRRV2D, IGERV2D + EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 UPLO, DIAG + LOGICAL TESTOK + INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST + INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE + INTEGER SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = -1 + RCHECKVAL = -2 +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + ISIZE = IBTSIZEOF('I') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + RDEST = RDEST0(ISO) + CDEST = CDEST0(ISO) + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF +* + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING', + $ UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ RDEST, CDEST, NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* source process generates matrix and sends it +* + IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN + CALL IINITMAT( UPLO, DIAG, M, N, MEM, LDASRC, + $ IPRE, IPOST, SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL ITRSD2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC, RDEST, CDEST ) + ELSE + CALL IGESD2D( CONTEXT, M, N, MEM(APTR), + $ LDASRC, RDEST, CDEST ) + END IF + END IF +* + IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN +* +* Pad entire matrix area +* + DO 50 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 50 CONTINUE +* +* Receive matrix +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL ITRRV2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC ) + ELSE + CALL IGERV2D( CONTEXT, M, N, MEM(APTR), + $ LDADST, RSRC, CSRC ) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL ICHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST, + $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) ) +* + CALL ICHKPAD( UPLO, DIAG, M, N, MEM, LDADST, + $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, + $ RCHECKVAL, TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR) ) + TESTOK = I .EQ. NERR + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL IBTCHECKIN( 0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL ) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. I.EQ.NERR ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ENDIF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('INTEGER SDRV TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ', + $ 'CSRC RDEST CDEST P Q') + 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ', + $ '---- ----- ----- ---- ----') + 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5) + 8000 FORMAT('INTEGER SDRV TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('INTEGER SDRV TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of ISDRVTEST. +* + END +* +* + SUBROUTINE SSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, + $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, + $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC) + INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*) + REAL MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* STESTSDRV: Test real send/recv +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) REAL array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL STRSD2D, SGESD2D, STRRV2D, SGERV2D + EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 UPLO, DIAG + LOGICAL TESTOK + INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST + INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE + REAL SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = -0.01E0 + RCHECKVAL = -0.02E0 +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + RDEST = RDEST0(ISO) + CDEST = CDEST0(ISO) + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF +* + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING', + $ UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ RDEST, CDEST, NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* source process generates matrix and sends it +* + IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN + CALL SINITMAT( UPLO, DIAG, M, N, MEM, LDASRC, + $ IPRE, IPOST, SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL STRSD2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC, RDEST, CDEST ) + ELSE + CALL SGESD2D( CONTEXT, M, N, MEM(APTR), + $ LDASRC, RDEST, CDEST ) + END IF + END IF +* + IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN +* +* Pad entire matrix area +* + DO 50 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 50 CONTINUE +* +* Receive matrix +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL STRRV2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC ) + ELSE + CALL SGERV2D( CONTEXT, M, N, MEM(APTR), + $ LDADST, RSRC, CSRC ) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL SCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST, + $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) ) +* + CALL SCHKPAD( UPLO, DIAG, M, N, MEM, LDADST, + $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, + $ RCHECKVAL, TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR) ) + TESTOK = I .EQ. NERR + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL SBTCHECKIN( 0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL ) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. I.EQ.NERR ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ENDIF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('REAL SDRV TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ', + $ 'CSRC RDEST CDEST P Q') + 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ', + $ '---- ----- ----- ---- ----') + 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5) + 8000 FORMAT('REAL SDRV TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('REAL SDRV TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of SSDRVTEST. +* + END +* +* + SUBROUTINE DSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, + $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, + $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC) + INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*) + DOUBLE PRECISION MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* DTESTSDRV: Test double precision send/recv +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL DTRSD2D, DGESD2D, DTRRV2D, DGERV2D + EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 UPLO, DIAG + LOGICAL TESTOK + INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST + INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE + DOUBLE PRECISION SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = -0.01D0 + RCHECKVAL = -0.02D0 +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + DSIZE = IBTSIZEOF('D') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + RDEST = RDEST0(ISO) + CDEST = CDEST0(ISO) + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF +* + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING', + $ UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ RDEST, CDEST, NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* source process generates matrix and sends it +* + IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN + CALL DINITMAT( UPLO, DIAG, M, N, MEM, LDASRC, + $ IPRE, IPOST, SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL DTRSD2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC, RDEST, CDEST ) + ELSE + CALL DGESD2D( CONTEXT, M, N, MEM(APTR), + $ LDASRC, RDEST, CDEST ) + END IF + END IF +* + IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN +* +* Pad entire matrix area +* + DO 50 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 50 CONTINUE +* +* Receive matrix +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL DTRRV2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC ) + ELSE + CALL DGERV2D( CONTEXT, M, N, MEM(APTR), + $ LDADST, RSRC, CSRC ) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL DCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST, + $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) ) +* + CALL DCHKPAD( UPLO, DIAG, M, N, MEM, LDADST, + $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, + $ RCHECKVAL, TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR) ) + TESTOK = I .EQ. NERR + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL DBTCHECKIN( 0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL ) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. I.EQ.NERR ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ENDIF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE PRECISION SDRV TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ', + $ 'CSRC RDEST CDEST P Q') + 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ', + $ '---- ----- ----- ---- ----') + 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5) + 8000 FORMAT('DOUBLE PRECISION SDRV TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('DOUBLE PRECISION SDRV TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of DSDRVTEST. +* + END +* +* + SUBROUTINE CSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, + $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, + $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC) + INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*) + COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* CTESTSDRV: Test complex send/recv +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL CTRSD2D, CGESD2D, CTRRV2D, CGERV2D + EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 UPLO, DIAG + LOGICAL TESTOK + INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST + INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE + COMPLEX SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = CMPLX( -0.01, -0.01 ) + RCHECKVAL = CMPLX( -0.02, -0.02 ) +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + CSIZE = IBTSIZEOF('C') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + RDEST = RDEST0(ISO) + CDEST = CDEST0(ISO) + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF +* + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING', + $ UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ RDEST, CDEST, NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* source process generates matrix and sends it +* + IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN + CALL CINITMAT( UPLO, DIAG, M, N, MEM, LDASRC, + $ IPRE, IPOST, SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL CTRSD2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC, RDEST, CDEST ) + ELSE + CALL CGESD2D( CONTEXT, M, N, MEM(APTR), + $ LDASRC, RDEST, CDEST ) + END IF + END IF +* + IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN +* +* Pad entire matrix area +* + DO 50 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 50 CONTINUE +* +* Receive matrix +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL CTRRV2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC ) + ELSE + CALL CGERV2D( CONTEXT, M, N, MEM(APTR), + $ LDADST, RSRC, CSRC ) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL CCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST, + $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) ) +* + CALL CCHKPAD( UPLO, DIAG, M, N, MEM, LDADST, + $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, + $ RCHECKVAL, TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR) ) + TESTOK = I .EQ. NERR + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL CBTCHECKIN( 0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL ) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. I.EQ.NERR ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ENDIF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('COMPLEX SDRV TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ', + $ 'CSRC RDEST CDEST P Q') + 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ', + $ '---- ----- ----- ---- ----') + 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5) + 8000 FORMAT('COMPLEX SDRV TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('COMPLEX SDRV TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of CSDRVTEST. +* + END +* +* + SUBROUTINE ZSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, + $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, + $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC) + INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*) + DOUBLE COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ZTESTSDRV: Test double complex send/recv +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNSRC) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL ZTRSD2D, ZGESD2D, ZTRRV2D, ZGERV2D + EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 UPLO, DIAG + LOGICAL TESTOK + INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST + INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE + DOUBLE COMPLEX SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = DCMPLX( -0.01D0, -0.01D0 ) + RCHECKVAL = DCMPLX( -0.02D0, -0.02D0 ) +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + ZSIZE = IBTSIZEOF('Z') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + RDEST = RDEST0(ISO) + CDEST = CDEST0(ISO) + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF +* + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING', + $ UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ RDEST, CDEST, NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* source process generates matrix and sends it +* + IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN + CALL ZINITMAT( UPLO, DIAG, M, N, MEM, LDASRC, + $ IPRE, IPOST, SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL ZTRSD2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC, RDEST, CDEST ) + ELSE + CALL ZGESD2D( CONTEXT, M, N, MEM(APTR), + $ LDASRC, RDEST, CDEST ) + END IF + END IF +* + IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN +* +* Pad entire matrix area +* + DO 50 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 50 CONTINUE +* +* Receive matrix +* + IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN + CALL ZTRRV2D( CONTEXT, UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC ) + ELSE + CALL ZGERV2D( CONTEXT, M, N, MEM(APTR), + $ LDADST, RSRC, CSRC ) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL ZCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST, + $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) ) +* + CALL ZCHKPAD( UPLO, DIAG, M, N, MEM, LDADST, + $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, + $ RCHECKVAL, TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR) ) + TESTOK = I .EQ. NERR + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL ZBTCHECKIN( 0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL ) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. I.EQ.NERR ) THEN + WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ', + $ UPLO, DIAG, M, N, LDASRC, LDADST, + $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL + ENDIF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE COMPLEX SDRV TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ', + $ 'CSRC RDEST CDEST P Q') + 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ', + $ '---- ----- ----- ---- ----') + 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5) + 8000 FORMAT('DOUBLE COMPLEX SDRV TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('DOUBLE COMPLEX SDRV TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of ZSDRVTEST. +* + END +* +* + SUBROUTINE IBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, + $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, + $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID + INTEGER MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), TFAIL(*) + INTEGER MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ITESTBSBR: Test integer broadcast +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) INTEGER array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL ITRBS2D, IGEBS2D, ITRBR2D, IGEBR2D + EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP, UPLO, DIAG + LOGICAL TESTOK, INGRID + INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO + INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC + INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE + INTEGER SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = -1 + RCHECKVAL = -2 +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + ISIZE = IBTSIZEOF('I') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + INGRID = ( NPROW .GT. 0 ) +* + DO 100 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 90 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multipath ('M') or general tree ('T'), +* need to loop over calls to BLACS_SET +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 11 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 12 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) + $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG, + $ M, N, LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* If I am in scope +* + IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* +* source process generates matrix and sends it +* + IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN + CALL IINITMAT(UPLO, DIAG, M, N, MEM, + $ LDASRC, IPRE, IPOST, + $ SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + DO 20 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 20 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL ITRBS2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC ) + ELSE + CALL IGEBS2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDASRC ) + END IF + 20 CONTINUE +* +* Destination processes +* + ELSE IF( INGRID ) THEN + DO 40 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 40 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* Pad entire matrix area +* + DO 30 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 30 CONTINUE +* +* Receive matrix +* + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL ITRBR2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, + $ RSRC, CSRC) + ELSE + CALL IGEBR2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDADST, RSRC, CSRC) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL ICHKMAT(UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR)) +* + CALL ICHKPAD(UPLO, DIAG, M, N, MEM, + $ LDADST, RSRC, CSRC, MYROW, + $ MYCOL, IPRE, IPOST, RCHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + 40 CONTINUE + TESTOK = ( I .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL IBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL) + IF( IAM .EQ. 0 ) THEN + TESTOK = ( TESTOK .AND. (I.EQ.NERR) ) + IF( TESTOK ) THEN + WRITE(OUTNUM,7000)TESTNUM,'PASSED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,7000)TESTNUM,'FAILED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('INTEGER BSBR TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ', + $ ' LDAD RSRC CSRC P Q') + 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ', + $ '----- ---- ---- ---- ----') + 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5) + 8000 FORMAT('INTEGER BSBR TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('INTEGER BSBR TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of IBSBRTEST. +* + END +* +* + SUBROUTINE SBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, + $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, + $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID + INTEGER MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), TFAIL(*) + REAL MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* STESTBSBR: Test real broadcast +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) REAL array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL STRBS2D, SGEBS2D, STRBR2D, SGEBR2D + EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP, UPLO, DIAG + LOGICAL TESTOK, INGRID + INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO + INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC + INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE + REAL SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = -0.01E0 + RCHECKVAL = -0.02E0 +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + INGRID = ( NPROW .GT. 0 ) +* + DO 100 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 90 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multipath ('M') or general tree ('T'), +* need to loop over calls to BLACS_SET +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 11 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 12 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) + $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG, + $ M, N, LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* If I am in scope +* + IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* +* source process generates matrix and sends it +* + IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN + CALL SINITMAT(UPLO, DIAG, M, N, MEM, + $ LDASRC, IPRE, IPOST, + $ SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + DO 20 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 20 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL STRBS2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC ) + ELSE + CALL SGEBS2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDASRC ) + END IF + 20 CONTINUE +* +* Destination processes +* + ELSE IF( INGRID ) THEN + DO 40 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 40 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* Pad entire matrix area +* + DO 30 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 30 CONTINUE +* +* Receive matrix +* + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL STRBR2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, + $ RSRC, CSRC) + ELSE + CALL SGEBR2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDADST, RSRC, CSRC) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL SCHKMAT(UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR)) +* + CALL SCHKPAD(UPLO, DIAG, M, N, MEM, + $ LDADST, RSRC, CSRC, MYROW, + $ MYCOL, IPRE, IPOST, RCHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + 40 CONTINUE + TESTOK = ( I .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL SBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL) + IF( IAM .EQ. 0 ) THEN + TESTOK = ( TESTOK .AND. (I.EQ.NERR) ) + IF( TESTOK ) THEN + WRITE(OUTNUM,7000)TESTNUM,'PASSED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,7000)TESTNUM,'FAILED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('REAL BSBR TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ', + $ ' LDAD RSRC CSRC P Q') + 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ', + $ '----- ---- ---- ---- ----') + 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5) + 8000 FORMAT('REAL BSBR TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('REAL BSBR TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of SBSBRTEST. +* + END +* +* + SUBROUTINE DBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, + $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, + $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID + INTEGER MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), TFAIL(*) + DOUBLE PRECISION MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* DTESTBSBR: Test double precision broadcast +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL DTRBS2D, DGEBS2D, DTRBR2D, DGEBR2D + EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP, UPLO, DIAG + LOGICAL TESTOK, INGRID + INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO + INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC + INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE + DOUBLE PRECISION SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = -0.01D0 + RCHECKVAL = -0.02D0 +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + DSIZE = IBTSIZEOF('D') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + INGRID = ( NPROW .GT. 0 ) +* + DO 100 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 90 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multipath ('M') or general tree ('T'), +* need to loop over calls to BLACS_SET +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 11 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 12 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) + $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG, + $ M, N, LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* If I am in scope +* + IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* +* source process generates matrix and sends it +* + IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN + CALL DINITMAT(UPLO, DIAG, M, N, MEM, + $ LDASRC, IPRE, IPOST, + $ SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + DO 20 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 20 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL DTRBS2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC ) + ELSE + CALL DGEBS2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDASRC ) + END IF + 20 CONTINUE +* +* Destination processes +* + ELSE IF( INGRID ) THEN + DO 40 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 40 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* Pad entire matrix area +* + DO 30 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 30 CONTINUE +* +* Receive matrix +* + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL DTRBR2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, + $ RSRC, CSRC) + ELSE + CALL DGEBR2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDADST, RSRC, CSRC) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL DCHKMAT(UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR)) +* + CALL DCHKPAD(UPLO, DIAG, M, N, MEM, + $ LDADST, RSRC, CSRC, MYROW, + $ MYCOL, IPRE, IPOST, RCHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + 40 CONTINUE + TESTOK = ( I .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL DBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL) + IF( IAM .EQ. 0 ) THEN + TESTOK = ( TESTOK .AND. (I.EQ.NERR) ) + IF( TESTOK ) THEN + WRITE(OUTNUM,7000)TESTNUM,'PASSED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,7000)TESTNUM,'FAILED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE PRECISION BSBR TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ', + $ ' LDAD RSRC CSRC P Q') + 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ', + $ '----- ---- ---- ---- ----') + 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5) + 8000 FORMAT('DOUBLE PRECISION BSBR TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('DOUBLE PRECISION BSBR TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of DBSBRTEST. +* + END +* +* + SUBROUTINE CBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, + $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, + $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID + INTEGER MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), TFAIL(*) + COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* CTESTBSBR: Test complex broadcast +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL CTRBS2D, CGEBS2D, CTRBR2D, CGEBR2D + EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP, UPLO, DIAG + LOGICAL TESTOK, INGRID + INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO + INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC + INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE + COMPLEX SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = CMPLX( -0.01, -0.01 ) + RCHECKVAL = CMPLX( -0.02, -0.02 ) +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + CSIZE = IBTSIZEOF('C') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + INGRID = ( NPROW .GT. 0 ) +* + DO 100 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 90 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multipath ('M') or general tree ('T'), +* need to loop over calls to BLACS_SET +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 11 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 12 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) + $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG, + $ M, N, LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* If I am in scope +* + IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* +* source process generates matrix and sends it +* + IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN + CALL CINITMAT(UPLO, DIAG, M, N, MEM, + $ LDASRC, IPRE, IPOST, + $ SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + DO 20 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 20 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL CTRBS2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC ) + ELSE + CALL CGEBS2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDASRC ) + END IF + 20 CONTINUE +* +* Destination processes +* + ELSE IF( INGRID ) THEN + DO 40 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 40 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* Pad entire matrix area +* + DO 30 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 30 CONTINUE +* +* Receive matrix +* + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL CTRBR2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, + $ RSRC, CSRC) + ELSE + CALL CGEBR2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDADST, RSRC, CSRC) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL CCHKMAT(UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR)) +* + CALL CCHKPAD(UPLO, DIAG, M, N, MEM, + $ LDADST, RSRC, CSRC, MYROW, + $ MYCOL, IPRE, IPOST, RCHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + 40 CONTINUE + TESTOK = ( I .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL CBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL) + IF( IAM .EQ. 0 ) THEN + TESTOK = ( TESTOK .AND. (I.EQ.NERR) ) + IF( TESTOK ) THEN + WRITE(OUTNUM,7000)TESTNUM,'PASSED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,7000)TESTNUM,'FAILED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('COMPLEX BSBR TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ', + $ ' LDAD RSRC CSRC P Q') + 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ', + $ '----- ---- ---- ---- ----') + 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5) + 8000 FORMAT('COMPLEX BSBR TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('COMPLEX BSBR TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of CBSBRTEST. +* + END +* +* + SUBROUTINE ZBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, + $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, + $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, + $ P0, Q0, TFAIL, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID + INTEGER MEMLEN +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), TFAIL(*) + DOUBLE COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ZTESTBSBR: Test double complex broadcast +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NSHAPE (input) INTEGER +* The number of matrix shapes to be tested. +* +* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of UPLO to be tested. +* +* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE) +* Values of DIAG to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NSRC (input) INTEGER +* The number of sources to be tested. +* +* RSRC0 (input) INTEGER array of dimension (NDEST) +* Values of RSRC (row coordinate of source) to be tested. +* +* CSRC0 (input) INTEGER array of dimension (NDEST) +* Values of CSRC (column coordinate of source) to be tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* TFAIL (workspace) INTEGER array of dimension (NTESTS) +* If VERB < 2, serves to indicate which tests fail. This +* requires workspace of NTESTS (number of tests performed). +* +* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO + EXTERNAL ZTRBS2D, ZGEBS2D, ZTRBR2D, ZGEBR2D + EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP, UPLO, DIAG + LOGICAL TESTOK, INGRID + INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO + INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC + INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT + INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC + INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE + DOUBLE COMPLEX SCHECKVAL, RCHECKVAL +* .. +* .. Executable Statements .. +* + SCHECKVAL = DCMPLX( -0.01D0, -0.01D0 ) + RCHECKVAL = DCMPLX( -0.02D0, -0.02D0 ) +* + IAM = IBTMYPROC() + ISIZE = IBTSIZEOF('I') + ZSIZE = IBTSIZEOF('Z') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE + WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NSRC :', NSRC + WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,5000) + WRITE(OUTNUM,6000) + END IF + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA) + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 110 IGR = 1, NGRID +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) +* + INGRID = ( NPROW .GT. 0 ) +* + DO 100 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 90 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multipath ('M') or general tree ('T'), +* need to loop over calls to BLACS_SET +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 11 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 12 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 80 ISH = 1, NSHAPE + UPLO = UPLO0(ISH) + DIAG = DIAG0(ISH) +* + DO 70 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) +* + DO 60 ISO = 1, NSRC + TESTNUM = TESTNUM + 1 + RSRC = RSRC0(ISO) + CSRC = CSRC0(ISO) + IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 60 + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 7000) + $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG, + $ M, N, LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* + TESTOK = .TRUE. + IPRE = 2 * M + IPOST = IPRE + APTR = IPRE + 1 +* +* If I am in scope +* + IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* +* source process generates matrix and sends it +* + IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN + CALL ZINITMAT(UPLO, DIAG, M, N, MEM, + $ LDASRC, IPRE, IPOST, + $ SCHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + DO 20 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 20 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL ZTRBS2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDASRC ) + ELSE + CALL ZGEBS2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDASRC ) + END IF + 20 CONTINUE +* +* Destination processes +* + ELSE IF( INGRID ) THEN + DO 40 J = ISTART, ISTOP + IF( J.EQ.0 ) GOTO 40 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* Pad entire matrix area +* + DO 30 K = 1, IPRE+IPOST+LDADST*N + MEM(K) = RCHECKVAL + 30 CONTINUE +* +* Receive matrix +* + IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN + CALL ZTRBR2D(CONTEXT, SCOPE, TOP, + $ UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, + $ RSRC, CSRC) + ELSE + CALL ZGEBR2D(CONTEXT, SCOPE, TOP, + $ M, N, MEM(APTR), + $ LDADST, RSRC, CSRC) + END IF +* +* Check for errors in matrix or padding +* + I = NERR + CALL ZCHKMAT(UPLO, DIAG, M, N, + $ MEM(APTR), LDADST, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, + $ NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR)) +* + CALL ZCHKPAD(UPLO, DIAG, M, N, MEM, + $ LDADST, RSRC, CSRC, MYROW, + $ MYCOL, IPRE, IPOST, RCHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + 40 CONTINUE + TESTOK = ( I .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL ZBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), + $ TFAIL) + IF( IAM .EQ. 0 ) THEN + TESTOK = ( TESTOK .AND. (I.EQ.NERR) ) + IF( TESTOK ) THEN + WRITE(OUTNUM,7000)TESTNUM,'PASSED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,7000)TESTNUM,'FAILED ', + $ SCOPE, TOP, UPLO, DIAG, M, N, + $ LDASRC, LDADST, RSRC, CSRC, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), TFAIL ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 8000 ) TESTNUM + ELSE + WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE COMPLEX BSBR TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ', + $ ' LDAD RSRC CSRC P Q') + 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ', + $ '----- ---- ---- ---- ----') + 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5) + 8000 FORMAT('DOUBLE COMPLEX BSBR TESTS: PASSED ALL', + $ I5, ' TESTS.') + 9000 FORMAT('DOUBLE COMPLEX BSBR TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of ZBSBRTEST. +* + END +* +* + SUBROUTINE RDCOMB( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, + $ OUTNUM ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM +* .. +* .. Array Arguments .. + CHARACTER*1 CMEM(CMEMLEN) + INTEGER MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* RDCOMB: Read and process the input file COMB.dat. +* +* Arguments +* ========= +* MEMUSED (output) INTEGER +* Number of elements in MEM that this subroutine ends up using. +* +* MEM (output) INTEGER array of dimension memlen +* On output, holds information read in from sdrv.dat. +* +* MEMLEN (input) INTEGER +* Number of elements of MEM that this subroutine +* may safely write into. +* +* CMEMUSED (output) INTEGER +* Number of elements in CMEM that this subroutine ends up using. +* +* CMEM (output) CHARACTER*1 array of dimension cmemlen +* On output, holds the values for UPLO and DIAG. +* +* CMEMLEN (input) INTEGER +* Number of elements of CMEM that this subroutine +* may safely write into. +* +* OUTNUM (input) INTEGER +* Unit number of the output file. +* +* ================================================================= +* +* .. Parameters .. + INTEGER SDIN + PARAMETER( SDIN = 12 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Local Scalars .. + INTEGER TOPSREPEAT, TOPSCOHRNT, NOPS, NSCOPE, NTOP, NMAT, NDEST + INTEGER NGRID, I, J, OPPTR, SCOPEPTR, TOPPTR, MPTR, NPTR + INTEGER LDSPTR, LDDPTR, LDIPTR, RDESTPTR, CDESTPTR, PPTR, QPTR +* .. +* .. Executable Statements +* +* Open and read the file comb.dat. The expected format is +* below. +* +*------ +*integer Number of operations +*array of CHAR*1's OPs: '+', '>', '<' +*integer Number of scopes +*array of CHAR*1's Values for Scopes +*HAR*1 Repeatability flag ('R', 'N', 'B') +*HAR*1 Coherency flag ('C', 'N', 'B') +*integer Number of topologies +*array of CHAR*1's Values for TOP +*integer number of nmat +*array of integers M: number of rows in matrix +*array of integers N: number of columns in matrix +*integer LDA: leading dimension on source proc +*integer LDA: leading dimension on dest proc +*integer number of source/dest pairs +*array of integers RDEST: process row of msg. dest. +*array of integers CDEST: process column of msg. dest. +*integer Number of grids +*array of integers NPROW: number of rows in process grid +*array of integers NPCOL: number of col's in proc. grid +*------ +* note: the text descriptions as shown above are present in +* the sample comb.dat included with this distribution, +* but are not required. +* +* Read input file +* + MEMUSED = 1 + CMEMUSED = 1 + OPEN(UNIT = SDIN, FILE = 'comb.dat', STATUS = 'OLD') +* +* Get what operations to test (+, >, <) +* + READ(SDIN, *) NOPS + OPPTR = CMEMUSED + CMEMUSED = OPPTR + NOPS + IF ( CMEMUSED .GT. CMEMLEN ) THEN + WRITE(OUTNUM, 1000) CMEMLEN, NOPS, 'OPERATIONS.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NOPS .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'OPERATIONS.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF +* + READ(SDIN, *) ( CMEM(OPPTR+I), I = 0, NOPS-1 ) + DO 10 I = 0, NOPS-1 + IF( (CMEM(OPPTR+I).NE.'+') .AND. (CMEM(OPPTR+I).NE.'>') .AND. + $ (CMEM(OPPTR+I).NE.'<') ) THEN + WRITE(OUTNUM,5000) CMEM(OPPTR+I) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + 10 CONTINUE +* +* Read in scopes and topologies +* + READ(SDIN, *) NSCOPE + SCOPEPTR = CMEMUSED + CMEMUSED = SCOPEPTR + NSCOPE + IF ( CMEMUSED .GT. CMEMLEN ) THEN + WRITE(OUTNUM, 1000) CMEMLEN, NSCOPE, 'SCOPES.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NSCOPE .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'SCOPE.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF +* + READ(SDIN, *) ( CMEM(SCOPEPTR+I), I = 0, NSCOPE-1 ) + DO 20 I = 0, NSCOPE-1 + IF( LSAME(CMEM(SCOPEPTR+I), 'R') ) THEN + CMEM(SCOPEPTR+I) = 'R' + ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'C') ) THEN + CMEM(SCOPEPTR+I) = 'C' + ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'A') ) THEN + CMEM(SCOPEPTR+I) = 'A' + ELSE + WRITE(OUTNUM, 3000) 'SCOPE', CMEM(SCOPEPTR+I) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + 20 CONTINUE +* + READ(SDIN, *) TOPSREPEAT + READ(SDIN, *) TOPSCOHRNT +* + READ(SDIN, *) NTOP + TOPPTR = CMEMUSED + CMEMUSED = TOPPTR + NTOP + IF ( CMEMUSED .GT. CMEMLEN ) THEN + WRITE(OUTNUM, 1000) CMEMLEN, NTOP, 'TOPOLOGIES.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NTOP .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'TOPOLOGY.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + READ(SDIN, *) ( CMEM(TOPPTR+I), I = 0, NTOP-1 ) +* +* +* Read in number of matrices, and values for M, N, LDASRC, and LDADEST +* + READ(SDIN, *) NMAT + MPTR = MEMUSED + NPTR = MPTR + NMAT + LDSPTR = NPTR + NMAT + LDDPTR = LDSPTR + NMAT + LDIPTR = LDDPTR + NMAT + MEMUSED = LDIPTR + NMAT + IF( MEMUSED .GT. MEMLEN ) THEN + WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'MATRICES.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NMAT .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'MATRIX.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + READ(SDIN, *) ( MEM( MPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( NPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( LDSPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( LDDPTR+I ), I = 0, NMAT-1 ) + READ(SDIN, *) ( MEM( LDIPTR+I ), I = 0, NMAT-1 ) +* +* Make sure matrix values are legal +* + CALL CHKMATDAT( OUTNUM, 'COMB.dat', .TRUE., NMAT, MEM(MPTR), + $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), MEM(LDIPTR) ) +* +* Read in number of dest pairs, and values of dest +* + READ(SDIN, *) NDEST + RDESTPTR = MEMUSED + CDESTPTR = RDESTPTR + NDEST + MEMUSED = CDESTPTR + NDEST + IF( MEMUSED .GT. MEMLEN ) THEN + WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'DEST.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NDEST .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'DEST.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + READ(SDIN, *) ( MEM(RDESTPTR+I), I = 0, NDEST-1 ) + READ(SDIN, *) ( MEM(CDESTPTR+I), I = 0, NDEST-1 ) +* +* Read in number of grids pairs, and values of P (process rows) and +* Q (process columns) +* + READ(SDIN, *) NGRID + PPTR = MEMUSED + QPTR = PPTR + NGRID + MEMUSED = QPTR + NGRID + IF( MEMUSED .GT. MEMLEN ) THEN + WRITE(OUTNUM, 1000) MEMLEN, NGRID, 'PROCESS GRIDS.' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + ELSE IF( NGRID .LT. 1 ) THEN + WRITE(OUTNUM, 2000) 'PROCESS GRID' + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM ) + STOP + END IF +* + READ(SDIN, *) ( MEM(PPTR+I), I = 0, NGRID-1 ) + READ(SDIN, *) ( MEM(QPTR+I), I = 0, NGRID-1 ) + IF( SDIN .NE. 6 .AND. SDIN .NE. 0 ) CLOSE( SDIN ) +* +* Fatal error if we've got an illegal grid +* + DO 70 J = 0, NGRID-1 + IF( MEM(PPTR+J).LT.1 .OR. MEM(QPTR+J).LT.1 ) THEN + WRITE(OUTNUM, 4000) MEM(PPTR+J), MEM(QPTR+J) + IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM) + STOP + END IF + 70 CONTINUE +* +* Prepare output variables +* + MEM(MEMUSED) = NOPS + MEM(MEMUSED+1) = NSCOPE + MEM(MEMUSED+2) = TOPSREPEAT + MEM(MEMUSED+3) = TOPSCOHRNT + MEM(MEMUSED+4) = NTOP + MEM(MEMUSED+5) = NMAT + MEM(MEMUSED+6) = NDEST + MEM(MEMUSED+7) = NGRID + MEMUSED = MEMUSED + 7 + CMEMUSED = CMEMUSED - 1 +* + 1000 FORMAT('Mem too short (',I4,') to handle',I4,' ',A20) + 2000 FORMAT('Must have at least one ',A20) + 3000 FORMAT('UNRECOGNIZABLE ',A5,' ''', A1, '''.') + 4000 FORMAT('Illegal process grid: {',I3,',',I3,'}.') + 5000 FORMAT('Illegal OP value ''',A1,''':, expected ''+'' (SUM),', + $ ' ''>'' (MAX), or ''<'' (MIN).') +* + RETURN +* +* End of RDCOMB. +* + END +* +* + SUBROUTINE IBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR, + $ IVAL, TFAILED ) + INTEGER NFTESTS, OUTNUM, MAXERR, NERR + INTEGER IERR(*), TFAILED(*) + INTEGER IVAL(*) +* +* Purpose +* ======= +* IBTCHECKIN: Process 0 receives error report from all processes. +* +* Arguments +* ========= +* NFTESTS (input/output) INTEGER +* if NFTESTS is <= 0 upon entry, NFTESTS is not written to. +* Otherwise, on entry it specifies the total number of tests +* run, and on exit it is the number of tests which failed. +* +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRIBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (workspace) INTEGER array, dimension NFTESTS +* Workspace used to keep track of which tests failed. +* If input of NFTESTS < 1, this array not accessed. +* +* =================================================================== +* +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID + EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID +* .. +* .. Local Scalars .. + LOGICAL COUNTING + INTEGER K, NERR2, IAM, NPROCS, NTESTS +* +* Proc 0 collects error info from everyone +* + IAM = IBTMYPROC() + NPROCS = IBTNPROCS() +* + IF( IAM .EQ. 0 ) THEN +* +* If we are finding out how many failed tests there are, initialize +* the total number of tests (NTESTS), and zero the test failed array +* + COUNTING = NFTESTS .GT. 0 + IF( COUNTING ) THEN + NTESTS = NFTESTS + DO 10 K = 1, NTESTS + TFAILED(K) = 0 + 10 CONTINUE + END IF +* + CALL IPRINTERRS(OUTNUM, MAXERR, NERR, IERR, IVAL, COUNTING, + $ TFAILED) +* + DO 20 K = 1, NPROCS-1 + CALL BTSEND(3, 0, K, K, IBTMSGID()+50) + CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50) + IF( NERR2 .GT. 0 ) THEN + NERR = NERR + NERR2 + CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51) + CALL BTRECV(3, NERR2*2, IVAL, K, IBTMSGID()+51) + CALL IPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, IVAL, + $ COUNTING, TFAILED) + END IF + 20 CONTINUE +* +* Count up number of tests that failed +* + IF( COUNTING ) THEN + NFTESTS = 0 + DO 30 K = 1, NTESTS + NFTESTS = NFTESTS + TFAILED(K) + 30 CONTINUE + END IF +* +* Send my error info to proc 0 +* + ELSE + CALL BTRECV(3, 0, K, 0, IBTMSGID()+50) + CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50) + IF( NERR .GT. 0 ) THEN + CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51) + CALL BTSEND(3, NERR*2, IVAL, 0, IBTMSGID()+51) + END IF + ENDIF +* + RETURN +* +* End of IBTCHECKIN +* + END +* + SUBROUTINE IINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, MYROW, MYCOL) + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL + INTEGER CHECKVAL + INTEGER MEM(*) +* +* .. External Subroutines .. + EXTERNAL IGENMAT, IPADMAT +* .. +* .. Executable Statements .. +* + CALL IGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL ) + CALL IPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL ) +* + RETURN + END +* + SUBROUTINE IGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL +* .. +* .. Array Arguments .. + INTEGER A(LDA,N) +* .. +* +* Purpose +* ======= +* IGENMAT: Generates an M-by-N matrix filled with random elements. +* +* Arguments +* ========= +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (output) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* TESTNUM (input) INTEGER +* Unique number for this test case, used as a basis for +* the random seeds. +* +* ==================================================================== +* +* .. External Functions .. + INTEGER IBTNPROCS + INTEGER IBTRAN + EXTERNAL IBTRAN, IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. Executable Statements .. +* +* ISEED's four values must be positive integers less than 4096, +* fourth one has to be odd. (see _LARND). Use some goofy +* functions to come up with seed values which together should +* be unique. +* + NPROCS = IBTNPROCS() + SRC = MYROW * NPROCS + MYCOL + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* + DO 10 J = 1, N + DO 10 I = 1, M + A(I, J) = IBTRAN( ISEED ) + 10 CONTINUE +* + RETURN +* +* End of IGENMAT. +* + END +* + INTEGER FUNCTION IBTRAN(ISEED) + INTEGER ISEED(*) +* +* .. External Functions .. + DOUBLE PRECISION DLARND + EXTERNAL DLARND +* .. +* .. Local Scalars .. + DOUBLE PRECISION DVAL +* .. +* .. Executable Statements .. +* + DVAL = 1.0D6 * DLARND(2, ISEED) + IBTRAN = INT(DVAL) +* + RETURN +* +* End of Ibtran +* + END +* + SUBROUTINE IPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST + INTEGER CHECKVAL +* .. +* .. Array Arguments .. + INTEGER MEM( * ) +* .. +* +* Purpose +* ======= +* +* IPADMAT: Pad Matrix. +* This routines surrounds a matrix with a guardzone initialized to the +* value CHECKVAL. There are three distinct guardzones: +* - A contiguous zone of size IPRE immediately before the start +* of the matrix. +* - A contiguous zone of size IPOST immedately after the end of the +* matrix. +* - Interstitial zones within each column of the matrix, in the +* elements A( M+1:LDA, J ). +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (output) integer array, dimension (IPRE+IPOST+LDA*N) +* The address IPRE elements ahead of the matrix A you want to +* pad, which is then of dimension (LDA,N). +* +* IPRE (input) INTEGER +* The size of the guard zone ahead of the matrix A. +* +* IPOST (input) INTEGER +* The size of the guard zone behind the matrix A. +* +* CHECKVAL (input) integer +* The value to insert into the guard zones. +* +* ==================================================================== +* +* .. Local Scalars .. + INTEGER I, J, K +* .. +* .. Executable Statements .. +* +* Put check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + MEM( I ) = CHECKVAL + 10 CONTINUE + END IF +* +* Put check buffer in back of A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + MEM( I ) = CHECKVAL + 20 CONTINUE + END IF +* +* Put check buffer in all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = K, K+LDA-M-1 + MEM( I ) = CHECKVAL + 30 CONTINUE + K = K + LDA + 40 CONTINUE + END IF +* +* If the matrix is upper or lower trapezoidal, calculate the +* additional triangular area which needs to be padded, Each +* element referred to is in the Ith row and the Jth column. +* + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 41 I = 1, M + DO 42 J = 1, I + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 42 CONTINUE + 41 CONTINUE + ELSE + DO 43 I = 2, M + DO 44 J = 1, I-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 44 CONTINUE + 43 CONTINUE + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + DO 45 I = M-N+1, M + DO 46 J = 1, I-(M-N) + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 46 CONTINUE + 45 CONTINUE + ELSE + DO 47 I = M-N+2, M + DO 48 J = 1, I-(M-N)-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 48 CONTINUE + 47 CONTINUE + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 49 I = 1, M + DO 50 J = N-M+I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 50 CONTINUE + 49 CONTINUE + ELSE + DO 51 I = 1, M-1 + DO 52 J = N-M+I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 52 CONTINUE + 51 CONTINUE + END IF + ELSE + IF( UPLO .EQ. 'U' ) THEN + DO 53 I = 1, N + DO 54 J = I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 54 CONTINUE + 53 CONTINUE + ELSE + DO 55 I = 1, N-1 + DO 56 J = I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 56 CONTINUE + 55 CONTINUE + END IF + END IF + END IF +* +* End of IPADMAT. +* + RETURN + END +* + SUBROUTINE ICHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, + $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST + INTEGER TESTNUM, MAXERR, NERR + INTEGER CHECKVAL +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + INTEGER MEM(*), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* ICHKPAD: Check padding put in by PADMAT. +* Checks that padding around target matrix has not been overwritten +* by the previous point-to-point or broadcast send. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (input) integer array, dimension(IPRE+IPOST+LDA*N). +* Memory location IPRE elements in front of the matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* IPRE (input) INTEGER +* The size of the guard zone before the start of A. +* +* IPOST (input) INTEGER +* The size of guard zone after A. +* +* CHECKVAL (input) integer +* The value to pad matrix with. +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRIBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + LOGICAL ISTRAP + INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST + INTEGER NPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = ERR_PRE + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 10 CONTINUE + END IF +* +* Check buffer behind A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I - J + 1 + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_POST + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 20 CONTINUE + END IF +* +* Check all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + DO 40 J = 1, N + DO 30 I = M+1, LDA + K = IPRE + (J-1)*LDA + I + IF( MEM(K) .NE. CHECKVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_GAP + ERRDBUF(1, NERR) = MEM(K) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* Determine limits of trapezoidal matrix +* + ISTRAP = .FALSE. + IF( UPLO .EQ. 'U' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 2 + IRND = M + ICST = 1 + ICND = M - 1 + ELSEIF( M .GT. N ) THEN + IRST = ( M-N ) + 2 + IRND = M + ICST = 1 + ICND = N - 1 + ENDIF + IF( DIAG .EQ. 'U' ) THEN + IRST = IRST - 1 + ICND = ICND + 1 + ENDIF + ELSE IF( UPLO .EQ. 'L' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 1 + IRND = 1 + ICST = ( N-M ) + 2 + ICND = N + ELSEIF( M .GT. N ) THEN + IRST = 1 + IRND = 1 + ICST = 2 + ICND = N + ENDIF + IF( DIAG .EQ. 'U' ) THEN + ICST = ICST - 1 + ENDIF + ENDIF +* +* Check elements and report any errors +* + IF( ISTRAP ) THEN + DO 100 J = ICST, ICND + DO 105 I = IRST, IRND + IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_TRI + ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I ) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 105 CONTINUE +* +* Update the limits to allow filling in padding +* + IF( UPLO .EQ. 'U' ) THEN + IRST = IRST + 1 + ELSE + IRND = IRND + 1 + ENDIF + 100 CONTINUE + END IF +* + RETURN +* +* End of ICHKPAD. +* + END +* + SUBROUTINE ICHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + INTEGER A(LDA,N), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* iCHKMAT: Check matrix to see whether there were any transmission +* errors. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRIBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC, DEST + LOGICAL USEIT + INTEGER COMPVAL +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + INTEGER IBTRAN + EXTERNAL IBTRAN, IBTNPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Initialize ISEED with the same values as used in IGENMAT. +* + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* +* Generate the elements randomly with the same method used in GENMAT. +* Note that for trapezoidal matrices, we generate all elements in the +* enclosing rectangle and then ignore the complementary triangle. +* + DO 100 J = 1, N + DO 105 I = 1, M + COMPVAL = IBTRAN( ISEED ) +* +* Now determine whether we actually need this value. The +* strategy is to chop out the proper triangle based on what +* particular kind of trapezoidal matrix we're dealing with. +* + USEIT = .TRUE. + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. J ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. M-N+J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. M-N+J ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( J. GE. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( J .GE. I ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + END IF +* +* Compare the generated value to the one that's in the +* received matrix. If they don't match, tack another +* error record onto what's already there. +* + IF( USEIT ) THEN + IF( A(I,J) .NE. COMPVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I, J) + ERRDBUF(2, NERR) = COMPVAL + END IF + END IF + END IF + 105 CONTINUE + 100 CONTINUE + RETURN +* +* End of ICHKMAT. +* + END +* + SUBROUTINE IPRINTERRS( OUTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF, COUNTING, TFAILED ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + LOGICAL COUNTING + INTEGER OUTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), TFAILED(*) + INTEGER ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* IPRINTERRS: Print errors that have been recorded +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRIBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (input/ourput) INTEGER array, dimension NTESTS +* Workspace used to keep track of which tests failed. +* This array not accessed unless COUNTING is true. +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + EXTERNAL IBTMYPROC, IBTNPROCS +* .. +* .. Local Scalars .. + CHARACTER*1 MAT + LOGICAL MATISINT + INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE +* .. +* .. Executable Statements .. +* + IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN + OLDTEST = -1 + NPROCS = IBTNPROCS() + PROW = ERRIBUF(3,1) / NPROCS + PCOL = MOD( ERRIBUF(3,1), NPROCS ) + IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000) +* + DO 20 I = 1, MIN( NERR, MAXERR ) + IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN + IF( OLDTEST .NE. -1 ) + $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I) + IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1 + OLDTEST = ERRIBUF(1, I) + END IF +* +* Print out error message depending on type of error +* + ERRTYPE = ERRIBUF(6, I) + IF( ERRTYPE .LT. -10 ) THEN + ERRTYPE = -ERRTYPE - 10 + MAT = 'C' + MATISINT = .TRUE. + ELSE IF( ERRTYPE .LT. 0 ) THEN + ERRTYPE = -ERRTYPE + MAT = 'R' + MATISINT = .TRUE. + ELSE + MATISINT = .FALSE. + END IF +* +* RA/CA arrays from MAX/MIN have different printing protocol +* + IF( MATISINT ) THEN + IF( ERRIBUF(2, I) .EQ. -1 ) THEN + WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE + WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), + $ INT( ERRDBUF(1,I) ) + END IF +* +* Have memory overwrites in matrix A +* + ELSE + IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,2000) ERRIBUF(5,I), ERRDBUF(2,I), + $ ERRDBUF(1,I) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,3000) ERRIBUF(4,I), ERRDBUF(2,I), + $ ERRDBUF(1,I) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,4000) ERRIBUF(4,I), ERRIBUF(5,I), + $ ERRDBUF(2,I), ERRDBUF(1,I) + ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN + WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I), + $ ERRDBUF(2,I), ERRDBUF(1,I) + ELSE + WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I), + $ ERRDBUF(2,I), ERRDBUF(1,I) + END IF + END IF + 20 CONTINUE + WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST +* + 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':') + 2000 FORMAT(' Buffer overwrite ',I4, + $ ' elements before the start of A:',/, + $ ' Expected=',I12, + $ '; Received=',I12) + 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:', + $ /,' Expected=',I12, + $ '; Received=',I12) + 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/, + $ ' Expected=',I12, + $ '; Received=',I12) + 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4, + $ '):',/,' Expected=',I12, + $ '; Received=',I12) + 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/, + $ ' Expected=',I12, + $ '; Received=',I12) + 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) + 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) +* + 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):' + $ ,/,' Expected=',I12,'; Received=',I12) +* +10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/, + $ ' Expected=',I12,'; Received=',I12) +11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent ' + $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12) +12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#', + $ I6,'.') +13000 FORMAT('WARNING: There were more errors than could be recorded.', + $ /,'Increase MEMELTS to get complete listing.') + RETURN +* +* End IPRINTERRS +* + END +* +* + SUBROUTINE SBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR, + $ SVAL, TFAILED ) + INTEGER NFTESTS, OUTNUM, MAXERR, NERR + INTEGER IERR(*), TFAILED(*) + REAL SVAL(*) +* +* Purpose +* ======= +* SBTCHECKIN: Process 0 receives error report from all processes. +* +* Arguments +* ========= +* NFTESTS (input/output) INTEGER +* if NFTESTS is <= 0 upon entry, NFTESTS is not written to. +* Otherwise, on entry it specifies the total number of tests +* run, and on exit it is the number of tests which failed. +* +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRSBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (workspace) INTEGER array, dimension NFTESTS +* Workspace used to keep track of which tests failed. +* If input of NFTESTS < 1, this array not accessed. +* +* =================================================================== +* +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID + EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID +* .. +* .. Local Scalars .. + LOGICAL COUNTING + INTEGER K, NERR2, IAM, NPROCS, NTESTS +* +* Proc 0 collects error info from everyone +* + IAM = IBTMYPROC() + NPROCS = IBTNPROCS() +* + IF( IAM .EQ. 0 ) THEN +* +* If we are finding out how many failed tests there are, initialize +* the total number of tests (NTESTS), and zero the test failed array +* + COUNTING = NFTESTS .GT. 0 + IF( COUNTING ) THEN + NTESTS = NFTESTS + DO 10 K = 1, NTESTS + TFAILED(K) = 0 + 10 CONTINUE + END IF +* + CALL SPRINTERRS(OUTNUM, MAXERR, NERR, IERR, SVAL, COUNTING, + $ TFAILED) +* + DO 20 K = 1, NPROCS-1 + CALL BTSEND(3, 0, K, K, IBTMSGID()+50) + CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50) + IF( NERR2 .GT. 0 ) THEN + NERR = NERR + NERR2 + CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51) + CALL BTRECV(4, NERR2*2, SVAL, K, IBTMSGID()+51) + CALL SPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, SVAL, + $ COUNTING, TFAILED) + END IF + 20 CONTINUE +* +* Count up number of tests that failed +* + IF( COUNTING ) THEN + NFTESTS = 0 + DO 30 K = 1, NTESTS + NFTESTS = NFTESTS + TFAILED(K) + 30 CONTINUE + END IF +* +* Send my error info to proc 0 +* + ELSE + CALL BTRECV(3, 0, K, 0, IBTMSGID()+50) + CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50) + IF( NERR .GT. 0 ) THEN + CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51) + CALL BTSEND(4, NERR*2, SVAL, 0, IBTMSGID()+51) + END IF + ENDIF +* + RETURN +* +* End of SBTCHECKIN +* + END +* + SUBROUTINE SINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, MYROW, MYCOL) + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL + REAL CHECKVAL + REAL MEM(*) +* +* .. External Subroutines .. + EXTERNAL SGENMAT, SPADMAT +* .. +* .. Executable Statements .. +* + CALL SGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL ) + CALL SPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL ) +* + RETURN + END +* + SUBROUTINE SGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL +* .. +* .. Array Arguments .. + REAL A(LDA,N) +* .. +* +* Purpose +* ======= +* SGENMAT: Generates an M-by-N matrix filled with random elements. +* +* Arguments +* ========= +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (output) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* TESTNUM (input) INTEGER +* Unique number for this test case, used as a basis for +* the random seeds. +* +* ==================================================================== +* +* .. External Functions .. + INTEGER IBTNPROCS + REAL SBTRAN + EXTERNAL SBTRAN, IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. Executable Statements .. +* +* ISEED's four values must be positive integers less than 4096, +* fourth one has to be odd. (see _LARND). Use some goofy +* functions to come up with seed values which together should +* be unique. +* + NPROCS = IBTNPROCS() + SRC = MYROW * NPROCS + MYCOL + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* + DO 10 J = 1, N + DO 10 I = 1, M + A(I, J) = SBTRAN( ISEED ) + 10 CONTINUE +* + RETURN +* +* End of SGENMAT. +* + END +* + REAL FUNCTION SBTRAN(ISEED) + INTEGER ISEED(*) +* +* .. External Functions .. + DOUBLE PRECISION DLARND + EXTERNAL DLARND +* .. Executable Statements .. +* + SBTRAN = REAL( DLARND(2, ISEED) ) +* + RETURN +* +* End of Sbtran +* + END +* + SUBROUTINE SPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST + REAL CHECKVAL +* .. +* .. Array Arguments .. + REAL MEM( * ) +* .. +* +* Purpose +* ======= +* +* SPADMAT: Pad Matrix. +* This routines surrounds a matrix with a guardzone initialized to the +* value CHECKVAL. There are three distinct guardzones: +* - A contiguous zone of size IPRE immediately before the start +* of the matrix. +* - A contiguous zone of size IPOST immedately after the end of the +* matrix. +* - Interstitial zones within each column of the matrix, in the +* elements A( M+1:LDA, J ). +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (output) real array, dimension (IPRE+IPOST+LDA*N) +* The address IPRE elements ahead of the matrix A you want to +* pad, which is then of dimension (LDA,N). +* +* IPRE (input) INTEGER +* The size of the guard zone ahead of the matrix A. +* +* IPOST (input) INTEGER +* The size of the guard zone behind the matrix A. +* +* CHECKVAL (input) real +* The value to insert into the guard zones. +* +* ==================================================================== +* +* .. Local Scalars .. + INTEGER I, J, K +* .. +* .. Executable Statements .. +* +* Put check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + MEM( I ) = CHECKVAL + 10 CONTINUE + END IF +* +* Put check buffer in back of A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + MEM( I ) = CHECKVAL + 20 CONTINUE + END IF +* +* Put check buffer in all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = K, K+LDA-M-1 + MEM( I ) = CHECKVAL + 30 CONTINUE + K = K + LDA + 40 CONTINUE + END IF +* +* If the matrix is upper or lower trapezoidal, calculate the +* additional triangular area which needs to be padded, Each +* element referred to is in the Ith row and the Jth column. +* + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 41 I = 1, M + DO 42 J = 1, I + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 42 CONTINUE + 41 CONTINUE + ELSE + DO 43 I = 2, M + DO 44 J = 1, I-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 44 CONTINUE + 43 CONTINUE + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + DO 45 I = M-N+1, M + DO 46 J = 1, I-(M-N) + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 46 CONTINUE + 45 CONTINUE + ELSE + DO 47 I = M-N+2, M + DO 48 J = 1, I-(M-N)-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 48 CONTINUE + 47 CONTINUE + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 49 I = 1, M + DO 50 J = N-M+I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 50 CONTINUE + 49 CONTINUE + ELSE + DO 51 I = 1, M-1 + DO 52 J = N-M+I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 52 CONTINUE + 51 CONTINUE + END IF + ELSE + IF( UPLO .EQ. 'U' ) THEN + DO 53 I = 1, N + DO 54 J = I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 54 CONTINUE + 53 CONTINUE + ELSE + DO 55 I = 1, N-1 + DO 56 J = I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 56 CONTINUE + 55 CONTINUE + END IF + END IF + END IF +* +* End of SPADMAT. +* + RETURN + END +* + SUBROUTINE SCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, + $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST + INTEGER TESTNUM, MAXERR, NERR + REAL CHECKVAL +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + REAL MEM(*), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* SCHKPAD: Check padding put in by PADMAT. +* Checks that padding around target matrix has not been overwritten +* by the previous point-to-point or broadcast send. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (input) real array, dimension(IPRE+IPOST+LDA*N). +* Memory location IPRE elements in front of the matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* IPRE (input) INTEGER +* The size of the guard zone before the start of A. +* +* IPOST (input) INTEGER +* The size of guard zone after A. +* +* CHECKVAL (input) real +* The value to pad matrix with. +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRSBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + LOGICAL ISTRAP + INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST + INTEGER NPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = ERR_PRE + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 10 CONTINUE + END IF +* +* Check buffer behind A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I - J + 1 + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_POST + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 20 CONTINUE + END IF +* +* Check all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + DO 40 J = 1, N + DO 30 I = M+1, LDA + K = IPRE + (J-1)*LDA + I + IF( MEM(K) .NE. CHECKVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_GAP + ERRDBUF(1, NERR) = MEM(K) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* Determine limits of trapezoidal matrix +* + ISTRAP = .FALSE. + IF( UPLO .EQ. 'U' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 2 + IRND = M + ICST = 1 + ICND = M - 1 + ELSEIF( M .GT. N ) THEN + IRST = ( M-N ) + 2 + IRND = M + ICST = 1 + ICND = N - 1 + ENDIF + IF( DIAG .EQ. 'U' ) THEN + IRST = IRST - 1 + ICND = ICND + 1 + ENDIF + ELSE IF( UPLO .EQ. 'L' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 1 + IRND = 1 + ICST = ( N-M ) + 2 + ICND = N + ELSEIF( M .GT. N ) THEN + IRST = 1 + IRND = 1 + ICST = 2 + ICND = N + ENDIF + IF( DIAG .EQ. 'U' ) THEN + ICST = ICST - 1 + ENDIF + ENDIF +* +* Check elements and report any errors +* + IF( ISTRAP ) THEN + DO 100 J = ICST, ICND + DO 105 I = IRST, IRND + IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_TRI + ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I ) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 105 CONTINUE +* +* Update the limits to allow filling in padding +* + IF( UPLO .EQ. 'U' ) THEN + IRST = IRST + 1 + ELSE + IRND = IRND + 1 + ENDIF + 100 CONTINUE + END IF +* + RETURN +* +* End of SCHKPAD. +* + END +* + SUBROUTINE SCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + REAL A(LDA,N), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* sCHKMAT: Check matrix to see whether there were any transmission +* errors. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRSBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC, DEST + LOGICAL USEIT + REAL COMPVAL +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + REAL SBTRAN + EXTERNAL SBTRAN, IBTNPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Initialize ISEED with the same values as used in SGENMAT. +* + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* +* Generate the elements randomly with the same method used in GENMAT. +* Note that for trapezoidal matrices, we generate all elements in the +* enclosing rectangle and then ignore the complementary triangle. +* + DO 100 J = 1, N + DO 105 I = 1, M + COMPVAL = SBTRAN( ISEED ) +* +* Now determine whether we actually need this value. The +* strategy is to chop out the proper triangle based on what +* particular kind of trapezoidal matrix we're dealing with. +* + USEIT = .TRUE. + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. J ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. M-N+J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. M-N+J ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( J. GE. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( J .GE. I ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + END IF +* +* Compare the generated value to the one that's in the +* received matrix. If they don't match, tack another +* error record onto what's already there. +* + IF( USEIT ) THEN + IF( A(I,J) .NE. COMPVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I, J) + ERRDBUF(2, NERR) = COMPVAL + END IF + END IF + END IF + 105 CONTINUE + 100 CONTINUE + RETURN +* +* End of SCHKMAT. +* + END +* + SUBROUTINE SPRINTERRS( OUTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF, COUNTING, TFAILED ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + LOGICAL COUNTING + INTEGER OUTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), TFAILED(*) + REAL ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* SPRINTERRS: Print errors that have been recorded +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRSBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (input/ourput) INTEGER array, dimension NTESTS +* Workspace used to keep track of which tests failed. +* This array not accessed unless COUNTING is true. +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + EXTERNAL IBTMYPROC, IBTNPROCS +* .. +* .. Local Scalars .. + CHARACTER*1 MAT + LOGICAL MATISINT + INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE +* .. +* .. Executable Statements .. +* + IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN + OLDTEST = -1 + NPROCS = IBTNPROCS() + PROW = ERRIBUF(3,1) / NPROCS + PCOL = MOD( ERRIBUF(3,1), NPROCS ) + IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000) +* + DO 20 I = 1, MIN( NERR, MAXERR ) + IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN + IF( OLDTEST .NE. -1 ) + $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I) + IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1 + OLDTEST = ERRIBUF(1, I) + END IF +* +* Print out error message depending on type of error +* + ERRTYPE = ERRIBUF(6, I) + IF( ERRTYPE .LT. -10 ) THEN + ERRTYPE = -ERRTYPE - 10 + MAT = 'C' + MATISINT = .TRUE. + ELSE IF( ERRTYPE .LT. 0 ) THEN + ERRTYPE = -ERRTYPE + MAT = 'R' + MATISINT = .TRUE. + ELSE + MATISINT = .FALSE. + END IF +* +* RA/CA arrays from MAX/MIN have different printing protocol +* + IF( MATISINT ) THEN + IF( ERRIBUF(2, I) .EQ. -1 ) THEN + WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE + WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), + $ INT( ERRDBUF(1,I) ) + END IF +* +* Have memory overwrites in matrix A +* + ELSE + IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,2000) ERRIBUF(5,I), ERRDBUF(2,I), + $ ERRDBUF(1,I) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,3000) ERRIBUF(4,I), ERRDBUF(2,I), + $ ERRDBUF(1,I) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,4000) ERRIBUF(4,I), ERRIBUF(5,I), + $ ERRDBUF(2,I), ERRDBUF(1,I) + ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN + WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I), + $ ERRDBUF(2,I), ERRDBUF(1,I) + ELSE + WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I), + $ ERRDBUF(2,I), ERRDBUF(1,I) + END IF + END IF + 20 CONTINUE + WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST +* + 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':') + 2000 FORMAT(' Buffer overwrite ',I4, + $ ' elements before the start of A:',/, + $ ' Expected=',G15.9, + $ '; Received=',G15.9) + 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:', + $ /,' Expected=',G15.9, + $ '; Received=',G15.9) + 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/, + $ ' Expected=',G15.9, + $ '; Received=',G15.9) + 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4, + $ '):',/,' Expected=',G15.9, + $ '; Received=',G15.9) + 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/, + $ ' Expected=',G15.9, + $ '; Received=',G15.9) + 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) + 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) +* + 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):' + $ ,/,' Expected=',I12,'; Received=',I12) +* +10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/, + $ ' Expected=',I12,'; Received=',I12) +11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent ' + $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12) +12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#', + $ I6,'.') +13000 FORMAT('WARNING: There were more errors than could be recorded.', + $ /,'Increase MEMELTS to get complete listing.') + RETURN +* +* End SPRINTERRS +* + END +* +* + SUBROUTINE DBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR, + $ DVAL, TFAILED ) + INTEGER NFTESTS, OUTNUM, MAXERR, NERR + INTEGER IERR(*), TFAILED(*) + DOUBLE PRECISION DVAL(*) +* +* Purpose +* ======= +* DBTCHECKIN: Process 0 receives error report from all processes. +* +* Arguments +* ========= +* NFTESTS (input/output) INTEGER +* if NFTESTS is <= 0 upon entry, NFTESTS is not written to. +* Otherwise, on entry it specifies the total number of tests +* run, and on exit it is the number of tests which failed. +* +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRDBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (workspace) INTEGER array, dimension NFTESTS +* Workspace used to keep track of which tests failed. +* If input of NFTESTS < 1, this array not accessed. +* +* =================================================================== +* +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID + EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID +* .. +* .. Local Scalars .. + LOGICAL COUNTING + INTEGER K, NERR2, IAM, NPROCS, NTESTS +* +* Proc 0 collects error info from everyone +* + IAM = IBTMYPROC() + NPROCS = IBTNPROCS() +* + IF( IAM .EQ. 0 ) THEN +* +* If we are finding out how many failed tests there are, initialize +* the total number of tests (NTESTS), and zero the test failed array +* + COUNTING = NFTESTS .GT. 0 + IF( COUNTING ) THEN + NTESTS = NFTESTS + DO 10 K = 1, NTESTS + TFAILED(K) = 0 + 10 CONTINUE + END IF +* + CALL DPRINTERRS(OUTNUM, MAXERR, NERR, IERR, DVAL, COUNTING, + $ TFAILED) +* + DO 20 K = 1, NPROCS-1 + CALL BTSEND(3, 0, K, K, IBTMSGID()+50) + CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50) + IF( NERR2 .GT. 0 ) THEN + NERR = NERR + NERR2 + CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51) + CALL BTRECV(6, NERR2*2, DVAL, K, IBTMSGID()+51) + CALL DPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, DVAL, + $ COUNTING, TFAILED) + END IF + 20 CONTINUE +* +* Count up number of tests that failed +* + IF( COUNTING ) THEN + NFTESTS = 0 + DO 30 K = 1, NTESTS + NFTESTS = NFTESTS + TFAILED(K) + 30 CONTINUE + END IF +* +* Send my error info to proc 0 +* + ELSE + CALL BTRECV(3, 0, K, 0, IBTMSGID()+50) + CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50) + IF( NERR .GT. 0 ) THEN + CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51) + CALL BTSEND(6, NERR*2, DVAL, 0, IBTMSGID()+51) + END IF + ENDIF +* + RETURN +* +* End of DBTCHECKIN +* + END +* + SUBROUTINE DINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, MYROW, MYCOL) + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL + DOUBLE PRECISION CHECKVAL + DOUBLE PRECISION MEM(*) +* +* .. External Subroutines .. + EXTERNAL DGENMAT, DPADMAT +* .. +* .. Executable Statements .. +* + CALL DGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL ) + CALL DPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL ) +* + RETURN + END +* + SUBROUTINE DGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,N) +* .. +* +* Purpose +* ======= +* DGENMAT: Generates an M-by-N matrix filled with random elements. +* +* Arguments +* ========= +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (output) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* TESTNUM (input) INTEGER +* Unique number for this test case, used as a basis for +* the random seeds. +* +* ==================================================================== +* +* .. External Functions .. + INTEGER IBTNPROCS + DOUBLE PRECISION DBTRAN + EXTERNAL DBTRAN, IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. Executable Statements .. +* +* ISEED's four values must be positive integers less than 4096, +* fourth one has to be odd. (see _LARND). Use some goofy +* functions to come up with seed values which together should +* be unique. +* + NPROCS = IBTNPROCS() + SRC = MYROW * NPROCS + MYCOL + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* + DO 10 J = 1, N + DO 10 I = 1, M + A(I, J) = DBTRAN( ISEED ) + 10 CONTINUE +* + RETURN +* +* End of DGENMAT. +* + END +* + DOUBLE PRECISION FUNCTION DBTRAN(ISEED) + INTEGER ISEED(*) +* +* .. External Functions .. + DOUBLE PRECISION DLARND + EXTERNAL DLARND +* .. Executable Statements .. +* + DBTRAN = DLARND(2, ISEED) +* + RETURN +* +* End of Dbtran +* + END +* + SUBROUTINE DPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST + DOUBLE PRECISION CHECKVAL +* .. +* .. Array Arguments .. + DOUBLE PRECISION MEM( * ) +* .. +* +* Purpose +* ======= +* +* DPADMAT: Pad Matrix. +* This routines surrounds a matrix with a guardzone initialized to the +* value CHECKVAL. There are three distinct guardzones: +* - A contiguous zone of size IPRE immediately before the start +* of the matrix. +* - A contiguous zone of size IPOST immedately after the end of the +* matrix. +* - Interstitial zones within each column of the matrix, in the +* elements A( M+1:LDA, J ). +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (output) double precision array, dimension (IPRE+IPOST+LDA*N) +* The address IPRE elements ahead of the matrix A you want to +* pad, which is then of dimension (LDA,N). +* +* IPRE (input) INTEGER +* The size of the guard zone ahead of the matrix A. +* +* IPOST (input) INTEGER +* The size of the guard zone behind the matrix A. +* +* CHECKVAL (input) double precision +* The value to insert into the guard zones. +* +* ==================================================================== +* +* .. Local Scalars .. + INTEGER I, J, K +* .. +* .. Executable Statements .. +* +* Put check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + MEM( I ) = CHECKVAL + 10 CONTINUE + END IF +* +* Put check buffer in back of A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + MEM( I ) = CHECKVAL + 20 CONTINUE + END IF +* +* Put check buffer in all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = K, K+LDA-M-1 + MEM( I ) = CHECKVAL + 30 CONTINUE + K = K + LDA + 40 CONTINUE + END IF +* +* If the matrix is upper or lower trapezoidal, calculate the +* additional triangular area which needs to be padded, Each +* element referred to is in the Ith row and the Jth column. +* + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 41 I = 1, M + DO 42 J = 1, I + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 42 CONTINUE + 41 CONTINUE + ELSE + DO 43 I = 2, M + DO 44 J = 1, I-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 44 CONTINUE + 43 CONTINUE + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + DO 45 I = M-N+1, M + DO 46 J = 1, I-(M-N) + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 46 CONTINUE + 45 CONTINUE + ELSE + DO 47 I = M-N+2, M + DO 48 J = 1, I-(M-N)-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 48 CONTINUE + 47 CONTINUE + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 49 I = 1, M + DO 50 J = N-M+I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 50 CONTINUE + 49 CONTINUE + ELSE + DO 51 I = 1, M-1 + DO 52 J = N-M+I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 52 CONTINUE + 51 CONTINUE + END IF + ELSE + IF( UPLO .EQ. 'U' ) THEN + DO 53 I = 1, N + DO 54 J = I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 54 CONTINUE + 53 CONTINUE + ELSE + DO 55 I = 1, N-1 + DO 56 J = I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 56 CONTINUE + 55 CONTINUE + END IF + END IF + END IF +* +* End of DPADMAT. +* + RETURN + END +* + SUBROUTINE DCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, + $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST + INTEGER TESTNUM, MAXERR, NERR + DOUBLE PRECISION CHECKVAL +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + DOUBLE PRECISION MEM(*), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* DCHKPAD: Check padding put in by PADMAT. +* Checks that padding around target matrix has not been overwritten +* by the previous point-to-point or broadcast send. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (input) double precision array, dimension(IPRE+IPOST+LDA*N). +* Memory location IPRE elements in front of the matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* IPRE (input) INTEGER +* The size of the guard zone before the start of A. +* +* IPOST (input) INTEGER +* The size of guard zone after A. +* +* CHECKVAL (input) double precision +* The value to pad matrix with. +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRDBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + LOGICAL ISTRAP + INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST + INTEGER NPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = ERR_PRE + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 10 CONTINUE + END IF +* +* Check buffer behind A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I - J + 1 + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_POST + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 20 CONTINUE + END IF +* +* Check all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + DO 40 J = 1, N + DO 30 I = M+1, LDA + K = IPRE + (J-1)*LDA + I + IF( MEM(K) .NE. CHECKVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_GAP + ERRDBUF(1, NERR) = MEM(K) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* Determine limits of trapezoidal matrix +* + ISTRAP = .FALSE. + IF( UPLO .EQ. 'U' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 2 + IRND = M + ICST = 1 + ICND = M - 1 + ELSEIF( M .GT. N ) THEN + IRST = ( M-N ) + 2 + IRND = M + ICST = 1 + ICND = N - 1 + ENDIF + IF( DIAG .EQ. 'U' ) THEN + IRST = IRST - 1 + ICND = ICND + 1 + ENDIF + ELSE IF( UPLO .EQ. 'L' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 1 + IRND = 1 + ICST = ( N-M ) + 2 + ICND = N + ELSEIF( M .GT. N ) THEN + IRST = 1 + IRND = 1 + ICST = 2 + ICND = N + ENDIF + IF( DIAG .EQ. 'U' ) THEN + ICST = ICST - 1 + ENDIF + ENDIF +* +* Check elements and report any errors +* + IF( ISTRAP ) THEN + DO 100 J = ICST, ICND + DO 105 I = IRST, IRND + IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_TRI + ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I ) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 105 CONTINUE +* +* Update the limits to allow filling in padding +* + IF( UPLO .EQ. 'U' ) THEN + IRST = IRST + 1 + ELSE + IRND = IRND + 1 + ENDIF + 100 CONTINUE + END IF +* + RETURN +* +* End of DCHKPAD. +* + END +* + SUBROUTINE DCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + DOUBLE PRECISION A(LDA,N), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* dCHKMAT: Check matrix to see whether there were any transmission +* errors. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRDBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC, DEST + LOGICAL USEIT + DOUBLE PRECISION COMPVAL +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + DOUBLE PRECISION DBTRAN + EXTERNAL DBTRAN, IBTNPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Initialize ISEED with the same values as used in DGENMAT. +* + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* +* Generate the elements randomly with the same method used in GENMAT. +* Note that for trapezoidal matrices, we generate all elements in the +* enclosing rectangle and then ignore the complementary triangle. +* + DO 100 J = 1, N + DO 105 I = 1, M + COMPVAL = DBTRAN( ISEED ) +* +* Now determine whether we actually need this value. The +* strategy is to chop out the proper triangle based on what +* particular kind of trapezoidal matrix we're dealing with. +* + USEIT = .TRUE. + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. J ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. M-N+J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. M-N+J ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( J. GE. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( J .GE. I ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + END IF +* +* Compare the generated value to the one that's in the +* received matrix. If they don't match, tack another +* error record onto what's already there. +* + IF( USEIT ) THEN + IF( A(I,J) .NE. COMPVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I, J) + ERRDBUF(2, NERR) = COMPVAL + END IF + END IF + END IF + 105 CONTINUE + 100 CONTINUE + RETURN +* +* End of DCHKMAT. +* + END +* + SUBROUTINE DPRINTERRS( OUTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF, COUNTING, TFAILED ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + LOGICAL COUNTING + INTEGER OUTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), TFAILED(*) + DOUBLE PRECISION ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* DPRINTERRS: Print errors that have been recorded +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRDBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (input/ourput) INTEGER array, dimension NTESTS +* Workspace used to keep track of which tests failed. +* This array not accessed unless COUNTING is true. +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + EXTERNAL IBTMYPROC, IBTNPROCS +* .. +* .. Local Scalars .. + CHARACTER*1 MAT + LOGICAL MATISINT + INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE +* .. +* .. Executable Statements .. +* + IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN + OLDTEST = -1 + NPROCS = IBTNPROCS() + PROW = ERRIBUF(3,1) / NPROCS + PCOL = MOD( ERRIBUF(3,1), NPROCS ) + IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000) +* + DO 20 I = 1, MIN( NERR, MAXERR ) + IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN + IF( OLDTEST .NE. -1 ) + $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I) + IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1 + OLDTEST = ERRIBUF(1, I) + END IF +* +* Print out error message depending on type of error +* + ERRTYPE = ERRIBUF(6, I) + IF( ERRTYPE .LT. -10 ) THEN + ERRTYPE = -ERRTYPE - 10 + MAT = 'C' + MATISINT = .TRUE. + ELSE IF( ERRTYPE .LT. 0 ) THEN + ERRTYPE = -ERRTYPE + MAT = 'R' + MATISINT = .TRUE. + ELSE + MATISINT = .FALSE. + END IF +* +* RA/CA arrays from MAX/MIN have different printing protocol +* + IF( MATISINT ) THEN + IF( ERRIBUF(2, I) .EQ. -1 ) THEN + WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE + WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), + $ INT( ERRDBUF(1,I) ) + END IF +* +* Have memory overwrites in matrix A +* + ELSE + IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,2000) ERRIBUF(5,I), ERRDBUF(2,I), + $ ERRDBUF(1,I) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,3000) ERRIBUF(4,I), ERRDBUF(2,I), + $ ERRDBUF(1,I) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,4000) ERRIBUF(4,I), ERRIBUF(5,I), + $ ERRDBUF(2,I), ERRDBUF(1,I) + ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN + WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I), + $ ERRDBUF(2,I), ERRDBUF(1,I) + ELSE + WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I), + $ ERRDBUF(2,I), ERRDBUF(1,I) + END IF + END IF + 20 CONTINUE + WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST +* + 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':') + 2000 FORMAT(' Buffer overwrite ',I4, + $ ' elements before the start of A:',/, + $ ' Expected=',G22.16, + $ '; Received=',G22.16) + 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:', + $ /,' Expected=',G22.16, + $ '; Received=',G22.16) + 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/, + $ ' Expected=',G22.16, + $ '; Received=',G22.16) + 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4, + $ '):',/,' Expected=',G22.16, + $ '; Received=',G22.16) + 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/, + $ ' Expected=',G22.16, + $ '; Received=',G22.16) + 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) + 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) +* + 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):' + $ ,/,' Expected=',I12,'; Received=',I12) +* +10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/, + $ ' Expected=',I12,'; Received=',I12) +11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent ' + $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12) +12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#', + $ I6,'.') +13000 FORMAT('WARNING: There were more errors than could be recorded.', + $ /,'Increase MEMELTS to get complete listing.') + RETURN +* +* End DPRINTERRS +* + END +* +* + SUBROUTINE CBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR, + $ CVAL, TFAILED ) + INTEGER NFTESTS, OUTNUM, MAXERR, NERR + INTEGER IERR(*), TFAILED(*) + COMPLEX CVAL(*) +* +* Purpose +* ======= +* CBTCHECKIN: Process 0 receives error report from all processes. +* +* Arguments +* ========= +* NFTESTS (input/output) INTEGER +* if NFTESTS is <= 0 upon entry, NFTESTS is not written to. +* Otherwise, on entry it specifies the total number of tests +* run, and on exit it is the number of tests which failed. +* +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRCBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (workspace) INTEGER array, dimension NFTESTS +* Workspace used to keep track of which tests failed. +* If input of NFTESTS < 1, this array not accessed. +* +* =================================================================== +* +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID + EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID +* .. +* .. Local Scalars .. + LOGICAL COUNTING + INTEGER K, NERR2, IAM, NPROCS, NTESTS +* +* Proc 0 collects error info from everyone +* + IAM = IBTMYPROC() + NPROCS = IBTNPROCS() +* + IF( IAM .EQ. 0 ) THEN +* +* If we are finding out how many failed tests there are, initialize +* the total number of tests (NTESTS), and zero the test failed array +* + COUNTING = NFTESTS .GT. 0 + IF( COUNTING ) THEN + NTESTS = NFTESTS + DO 10 K = 1, NTESTS + TFAILED(K) = 0 + 10 CONTINUE + END IF +* + CALL CPRINTERRS(OUTNUM, MAXERR, NERR, IERR, CVAL, COUNTING, + $ TFAILED) +* + DO 20 K = 1, NPROCS-1 + CALL BTSEND(3, 0, K, K, IBTMSGID()+50) + CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50) + IF( NERR2 .GT. 0 ) THEN + NERR = NERR + NERR2 + CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51) + CALL BTRECV(5, NERR2*2, CVAL, K, IBTMSGID()+51) + CALL CPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, CVAL, + $ COUNTING, TFAILED) + END IF + 20 CONTINUE +* +* Count up number of tests that failed +* + IF( COUNTING ) THEN + NFTESTS = 0 + DO 30 K = 1, NTESTS + NFTESTS = NFTESTS + TFAILED(K) + 30 CONTINUE + END IF +* +* Send my error info to proc 0 +* + ELSE + CALL BTRECV(3, 0, K, 0, IBTMSGID()+50) + CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50) + IF( NERR .GT. 0 ) THEN + CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51) + CALL BTSEND(5, NERR*2, CVAL, 0, IBTMSGID()+51) + END IF + ENDIF +* + RETURN +* +* End of CBTCHECKIN +* + END +* + SUBROUTINE CINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, MYROW, MYCOL) + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL + COMPLEX CHECKVAL + COMPLEX MEM(*) +* +* .. External Subroutines .. + EXTERNAL CGENMAT, CPADMAT +* .. +* .. Executable Statements .. +* + CALL CGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL ) + CALL CPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL ) +* + RETURN + END +* + SUBROUTINE CGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL +* .. +* .. Array Arguments .. + COMPLEX A(LDA,N) +* .. +* +* Purpose +* ======= +* CGENMAT: Generates an M-by-N matrix filled with random elements. +* +* Arguments +* ========= +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (output) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* TESTNUM (input) INTEGER +* Unique number for this test case, used as a basis for +* the random seeds. +* +* ==================================================================== +* +* .. External Functions .. + INTEGER IBTNPROCS + COMPLEX CBTRAN + EXTERNAL CBTRAN, IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. Executable Statements .. +* +* ISEED's four values must be positive integers less than 4096, +* fourth one has to be odd. (see _LARND). Use some goofy +* functions to come up with seed values which together should +* be unique. +* + NPROCS = IBTNPROCS() + SRC = MYROW * NPROCS + MYCOL + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* + DO 10 J = 1, N + DO 10 I = 1, M + A(I, J) = CBTRAN( ISEED ) + 10 CONTINUE +* + RETURN +* +* End of CGENMAT. +* + END +* + COMPLEX FUNCTION CBTRAN(ISEED) + INTEGER ISEED(*) +* +* .. External Functions .. + DOUBLE COMPLEX ZLARND + EXTERNAL ZLARND + CBTRAN = CMPLX( ZLARND(2, ISEED) ) +* + RETURN +* +* End of Cbtran +* + END +* + SUBROUTINE CPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST + COMPLEX CHECKVAL +* .. +* .. Array Arguments .. + COMPLEX MEM( * ) +* .. +* +* Purpose +* ======= +* +* CPADMAT: Pad Matrix. +* This routines surrounds a matrix with a guardzone initialized to the +* value CHECKVAL. There are three distinct guardzones: +* - A contiguous zone of size IPRE immediately before the start +* of the matrix. +* - A contiguous zone of size IPOST immedately after the end of the +* matrix. +* - Interstitial zones within each column of the matrix, in the +* elements A( M+1:LDA, J ). +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (output) complex array, dimension (IPRE+IPOST+LDA*N) +* The address IPRE elements ahead of the matrix A you want to +* pad, which is then of dimension (LDA,N). +* +* IPRE (input) INTEGER +* The size of the guard zone ahead of the matrix A. +* +* IPOST (input) INTEGER +* The size of the guard zone behind the matrix A. +* +* CHECKVAL (input) complex +* The value to insert into the guard zones. +* +* ==================================================================== +* +* .. Local Scalars .. + INTEGER I, J, K +* .. +* .. Executable Statements .. +* +* Put check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + MEM( I ) = CHECKVAL + 10 CONTINUE + END IF +* +* Put check buffer in back of A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + MEM( I ) = CHECKVAL + 20 CONTINUE + END IF +* +* Put check buffer in all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = K, K+LDA-M-1 + MEM( I ) = CHECKVAL + 30 CONTINUE + K = K + LDA + 40 CONTINUE + END IF +* +* If the matrix is upper or lower trapezoidal, calculate the +* additional triangular area which needs to be padded, Each +* element referred to is in the Ith row and the Jth column. +* + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 41 I = 1, M + DO 42 J = 1, I + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 42 CONTINUE + 41 CONTINUE + ELSE + DO 43 I = 2, M + DO 44 J = 1, I-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 44 CONTINUE + 43 CONTINUE + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + DO 45 I = M-N+1, M + DO 46 J = 1, I-(M-N) + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 46 CONTINUE + 45 CONTINUE + ELSE + DO 47 I = M-N+2, M + DO 48 J = 1, I-(M-N)-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 48 CONTINUE + 47 CONTINUE + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 49 I = 1, M + DO 50 J = N-M+I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 50 CONTINUE + 49 CONTINUE + ELSE + DO 51 I = 1, M-1 + DO 52 J = N-M+I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 52 CONTINUE + 51 CONTINUE + END IF + ELSE + IF( UPLO .EQ. 'U' ) THEN + DO 53 I = 1, N + DO 54 J = I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 54 CONTINUE + 53 CONTINUE + ELSE + DO 55 I = 1, N-1 + DO 56 J = I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 56 CONTINUE + 55 CONTINUE + END IF + END IF + END IF +* +* End of CPADMAT. +* + RETURN + END +* + SUBROUTINE CCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, + $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST + INTEGER TESTNUM, MAXERR, NERR + COMPLEX CHECKVAL +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + COMPLEX MEM(*), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* CCHKPAD: Check padding put in by PADMAT. +* Checks that padding around target matrix has not been overwritten +* by the previous point-to-point or broadcast send. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (input) complex array, dimension(IPRE+IPOST+LDA*N). +* Memory location IPRE elements in front of the matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* IPRE (input) INTEGER +* The size of the guard zone before the start of A. +* +* IPOST (input) INTEGER +* The size of guard zone after A. +* +* CHECKVAL (input) complex +* The value to pad matrix with. +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRCBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + LOGICAL ISTRAP + INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST + INTEGER NPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = ERR_PRE + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 10 CONTINUE + END IF +* +* Check buffer behind A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I - J + 1 + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_POST + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 20 CONTINUE + END IF +* +* Check all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + DO 40 J = 1, N + DO 30 I = M+1, LDA + K = IPRE + (J-1)*LDA + I + IF( MEM(K) .NE. CHECKVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_GAP + ERRDBUF(1, NERR) = MEM(K) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* Determine limits of trapezoidal matrix +* + ISTRAP = .FALSE. + IF( UPLO .EQ. 'U' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 2 + IRND = M + ICST = 1 + ICND = M - 1 + ELSEIF( M .GT. N ) THEN + IRST = ( M-N ) + 2 + IRND = M + ICST = 1 + ICND = N - 1 + ENDIF + IF( DIAG .EQ. 'U' ) THEN + IRST = IRST - 1 + ICND = ICND + 1 + ENDIF + ELSE IF( UPLO .EQ. 'L' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 1 + IRND = 1 + ICST = ( N-M ) + 2 + ICND = N + ELSEIF( M .GT. N ) THEN + IRST = 1 + IRND = 1 + ICST = 2 + ICND = N + ENDIF + IF( DIAG .EQ. 'U' ) THEN + ICST = ICST - 1 + ENDIF + ENDIF +* +* Check elements and report any errors +* + IF( ISTRAP ) THEN + DO 100 J = ICST, ICND + DO 105 I = IRST, IRND + IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_TRI + ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I ) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 105 CONTINUE +* +* Update the limits to allow filling in padding +* + IF( UPLO .EQ. 'U' ) THEN + IRST = IRST + 1 + ELSE + IRND = IRND + 1 + ENDIF + 100 CONTINUE + END IF +* + RETURN +* +* End of CCHKPAD. +* + END +* + SUBROUTINE CCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + COMPLEX A(LDA,N), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* cCHKMAT: Check matrix to see whether there were any transmission +* errors. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRCBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC, DEST + LOGICAL USEIT + COMPLEX COMPVAL +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + COMPLEX CBTRAN + EXTERNAL CBTRAN, IBTNPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Initialize ISEED with the same values as used in CGENMAT. +* + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* +* Generate the elements randomly with the same method used in GENMAT. +* Note that for trapezoidal matrices, we generate all elements in the +* enclosing rectangle and then ignore the complementary triangle. +* + DO 100 J = 1, N + DO 105 I = 1, M + COMPVAL = CBTRAN( ISEED ) +* +* Now determine whether we actually need this value. The +* strategy is to chop out the proper triangle based on what +* particular kind of trapezoidal matrix we're dealing with. +* + USEIT = .TRUE. + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. J ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. M-N+J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. M-N+J ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( J. GE. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( J .GE. I ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + END IF +* +* Compare the generated value to the one that's in the +* received matrix. If they don't match, tack another +* error record onto what's already there. +* + IF( USEIT ) THEN + IF( A(I,J) .NE. COMPVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I, J) + ERRDBUF(2, NERR) = COMPVAL + END IF + END IF + END IF + 105 CONTINUE + 100 CONTINUE + RETURN +* +* End of CCHKMAT. +* + END +* + SUBROUTINE CPRINTERRS( OUTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF, COUNTING, TFAILED ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + LOGICAL COUNTING + INTEGER OUTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), TFAILED(*) + COMPLEX ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* CPRINTERRS: Print errors that have been recorded +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRCBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (input/ourput) INTEGER array, dimension NTESTS +* Workspace used to keep track of which tests failed. +* This array not accessed unless COUNTING is true. +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + EXTERNAL IBTMYPROC, IBTNPROCS +* .. +* .. Local Scalars .. + CHARACTER*1 MAT + LOGICAL MATISINT + INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE +* .. +* .. Executable Statements .. +* + IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN + OLDTEST = -1 + NPROCS = IBTNPROCS() + PROW = ERRIBUF(3,1) / NPROCS + PCOL = MOD( ERRIBUF(3,1), NPROCS ) + IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000) +* + DO 20 I = 1, MIN( NERR, MAXERR ) + IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN + IF( OLDTEST .NE. -1 ) + $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I) + IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1 + OLDTEST = ERRIBUF(1, I) + END IF +* +* Print out error message depending on type of error +* + ERRTYPE = ERRIBUF(6, I) + IF( ERRTYPE .LT. -10 ) THEN + ERRTYPE = -ERRTYPE - 10 + MAT = 'C' + MATISINT = .TRUE. + ELSE IF( ERRTYPE .LT. 0 ) THEN + ERRTYPE = -ERRTYPE + MAT = 'R' + MATISINT = .TRUE. + ELSE + MATISINT = .FALSE. + END IF +* +* RA/CA arrays from MAX/MIN have different printing protocol +* + IF( MATISINT ) THEN + IF( ERRIBUF(2, I) .EQ. -1 ) THEN + WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE + WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), + $ INT( ERRDBUF(1,I) ) + END IF +* +* Have memory overwrites in matrix A +* + ELSE + IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,2000) ERRIBUF(5,I), + $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,3000) ERRIBUF(4,I), + $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,4000) + $ ERRIBUF(4,I), ERRIBUF(5,I), + $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN + WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I), + $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) ) + ELSE + WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I), + $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) ) + END IF + END IF + 20 CONTINUE + WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST +* + 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':') + 2000 FORMAT(' Buffer overwrite ',I4, + $ ' elements before the start of A:',/, + $ ' Expected=','[',G15.9,',',G15.9,']', + $ '; Received=','[',G15.9,',',G15.9,']') + 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:', + $ /,' Expected=','[',G15.9,',',G15.9,']', + $ '; Received=','[',G15.9,',',G15.9,']') + 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/, + $ ' Expected=','[',G15.9,',',G15.9,']', + $ '; Received=','[',G15.9,',',G15.9,']') + 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4, + $ '):',/,' Expected=','[',G15.9,',',G15.9,']', + $ '; Received=','[',G15.9,',',G15.9,']') + 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/, + $ ' Expected=','[',G15.9,',',G15.9,']', + $ '; Received=','[',G15.9,',',G15.9,']') + 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) + 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) +* + 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):' + $ ,/,' Expected=',I12,'; Received=',I12) +* +10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/, + $ ' Expected=',I12,'; Received=',I12) +11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent ' + $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12) +12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#', + $ I6,'.') +13000 FORMAT('WARNING: There were more errors than could be recorded.', + $ /,'Increase MEMELTS to get complete listing.') + RETURN +* +* End CPRINTERRS +* + END +* +* + SUBROUTINE ZBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR, + $ ZVAL, TFAILED ) + INTEGER NFTESTS, OUTNUM, MAXERR, NERR + INTEGER IERR(*), TFAILED(*) + DOUBLE COMPLEX ZVAL(*) +* +* Purpose +* ======= +* ZBTCHECKIN: Process 0 receives error report from all processes. +* +* Arguments +* ========= +* NFTESTS (input/output) INTEGER +* if NFTESTS is <= 0 upon entry, NFTESTS is not written to. +* Otherwise, on entry it specifies the total number of tests +* run, and on exit it is the number of tests which failed. +* +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRZBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (workspace) INTEGER array, dimension NFTESTS +* Workspace used to keep track of which tests failed. +* If input of NFTESTS < 1, this array not accessed. +* +* =================================================================== +* +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID + EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID +* .. +* .. Local Scalars .. + LOGICAL COUNTING + INTEGER K, NERR2, IAM, NPROCS, NTESTS +* +* Proc 0 collects error info from everyone +* + IAM = IBTMYPROC() + NPROCS = IBTNPROCS() +* + IF( IAM .EQ. 0 ) THEN +* +* If we are finding out how many failed tests there are, initialize +* the total number of tests (NTESTS), and zero the test failed array +* + COUNTING = NFTESTS .GT. 0 + IF( COUNTING ) THEN + NTESTS = NFTESTS + DO 10 K = 1, NTESTS + TFAILED(K) = 0 + 10 CONTINUE + END IF +* + CALL ZPRINTERRS(OUTNUM, MAXERR, NERR, IERR, ZVAL, COUNTING, + $ TFAILED) +* + DO 20 K = 1, NPROCS-1 + CALL BTSEND(3, 0, K, K, IBTMSGID()+50) + CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50) + IF( NERR2 .GT. 0 ) THEN + NERR = NERR + NERR2 + CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51) + CALL BTRECV(7, NERR2*2, ZVAL, K, IBTMSGID()+51) + CALL ZPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, ZVAL, + $ COUNTING, TFAILED) + END IF + 20 CONTINUE +* +* Count up number of tests that failed +* + IF( COUNTING ) THEN + NFTESTS = 0 + DO 30 K = 1, NTESTS + NFTESTS = NFTESTS + TFAILED(K) + 30 CONTINUE + END IF +* +* Send my error info to proc 0 +* + ELSE + CALL BTRECV(3, 0, K, 0, IBTMSGID()+50) + CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50) + IF( NERR .GT. 0 ) THEN + CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51) + CALL BTSEND(7, NERR*2, ZVAL, 0, IBTMSGID()+51) + END IF + ENDIF +* + RETURN +* +* End of ZBTCHECKIN +* + END +* + SUBROUTINE ZINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, MYROW, MYCOL) + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL + DOUBLE COMPLEX CHECKVAL + DOUBLE COMPLEX MEM(*) +* +* .. External Subroutines .. + EXTERNAL ZGENMAT, ZPADMAT +* .. +* .. Executable Statements .. +* + CALL ZGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL ) + CALL ZPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL ) +* + RETURN + END +* + SUBROUTINE ZGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL +* .. +* .. Array Arguments .. + DOUBLE COMPLEX A(LDA,N) +* .. +* +* Purpose +* ======= +* ZGENMAT: Generates an M-by-N matrix filled with random elements. +* +* Arguments +* ========= +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (output) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* TESTNUM (input) INTEGER +* Unique number for this test case, used as a basis for +* the random seeds. +* +* ==================================================================== +* +* .. External Functions .. + INTEGER IBTNPROCS + DOUBLE COMPLEX ZBTRAN + EXTERNAL ZBTRAN, IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. Executable Statements .. +* +* ISEED's four values must be positive integers less than 4096, +* fourth one has to be odd. (see _LARND). Use some goofy +* functions to come up with seed values which together should +* be unique. +* + NPROCS = IBTNPROCS() + SRC = MYROW * NPROCS + MYCOL + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* + DO 10 J = 1, N + DO 10 I = 1, M + A(I, J) = ZBTRAN( ISEED ) + 10 CONTINUE +* + RETURN +* +* End of ZGENMAT. +* + END +* + DOUBLE COMPLEX FUNCTION ZBTRAN(ISEED) + INTEGER ISEED(*) +* +* .. External Functions .. + DOUBLE COMPLEX ZLARND + EXTERNAL ZLARND + ZBTRAN = ZLARND(2, ISEED) +* + RETURN +* +* End of Zbtran +* + END +* + SUBROUTINE ZPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, + $ CHECKVAL ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, IPRE, IPOST + DOUBLE COMPLEX CHECKVAL +* .. +* .. Array Arguments .. + DOUBLE COMPLEX MEM( * ) +* .. +* +* Purpose +* ======= +* +* ZPADMAT: Pad Matrix. +* This routines surrounds a matrix with a guardzone initialized to the +* value CHECKVAL. There are three distinct guardzones: +* - A contiguous zone of size IPRE immediately before the start +* of the matrix. +* - A contiguous zone of size IPOST immedately after the end of the +* matrix. +* - Interstitial zones within each column of the matrix, in the +* elements A( M+1:LDA, J ). +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (output) double complex array, dimension (IPRE+IPOST+LDA*N) +* The address IPRE elements ahead of the matrix A you want to +* pad, which is then of dimension (LDA,N). +* +* IPRE (input) INTEGER +* The size of the guard zone ahead of the matrix A. +* +* IPOST (input) INTEGER +* The size of the guard zone behind the matrix A. +* +* CHECKVAL (input) double complex +* The value to insert into the guard zones. +* +* ==================================================================== +* +* .. Local Scalars .. + INTEGER I, J, K +* .. +* .. Executable Statements .. +* +* Put check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + MEM( I ) = CHECKVAL + 10 CONTINUE + END IF +* +* Put check buffer in back of A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + MEM( I ) = CHECKVAL + 20 CONTINUE + END IF +* +* Put check buffer in all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = K, K+LDA-M-1 + MEM( I ) = CHECKVAL + 30 CONTINUE + K = K + LDA + 40 CONTINUE + END IF +* +* If the matrix is upper or lower trapezoidal, calculate the +* additional triangular area which needs to be padded, Each +* element referred to is in the Ith row and the Jth column. +* + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 41 I = 1, M + DO 42 J = 1, I + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 42 CONTINUE + 41 CONTINUE + ELSE + DO 43 I = 2, M + DO 44 J = 1, I-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 44 CONTINUE + 43 CONTINUE + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + DO 45 I = M-N+1, M + DO 46 J = 1, I-(M-N) + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 46 CONTINUE + 45 CONTINUE + ELSE + DO 47 I = M-N+2, M + DO 48 J = 1, I-(M-N)-1 + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 48 CONTINUE + 47 CONTINUE + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + DO 49 I = 1, M + DO 50 J = N-M+I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 50 CONTINUE + 49 CONTINUE + ELSE + DO 51 I = 1, M-1 + DO 52 J = N-M+I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 52 CONTINUE + 51 CONTINUE + END IF + ELSE + IF( UPLO .EQ. 'U' ) THEN + DO 53 I = 1, N + DO 54 J = I, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 54 CONTINUE + 53 CONTINUE + ELSE + DO 55 I = 1, N-1 + DO 56 J = I+1, N + K = IPRE + I + (J-1)*LDA + MEM( K ) = CHECKVAL + 56 CONTINUE + 55 CONTINUE + END IF + END IF + END IF +* +* End of ZPADMAT. +* + RETURN + END +* + SUBROUTINE ZCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, + $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST + INTEGER TESTNUM, MAXERR, NERR + DOUBLE COMPLEX CHECKVAL +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + DOUBLE COMPLEX MEM(*), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* ZCHKPAD: Check padding put in by PADMAT. +* Checks that padding around target matrix has not been overwritten +* by the previous point-to-point or broadcast send. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* MEM (input) double complex array, dimension(IPRE+IPOST+LDA*N). +* Memory location IPRE elements in front of the matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* IPRE (input) INTEGER +* The size of the guard zone before the start of A. +* +* IPOST (input) INTEGER +* The size of guard zone after A. +* +* CHECKVAL (input) double complex +* The value to pad matrix with. +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRZBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + LOGICAL ISTRAP + INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST + INTEGER NPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Check buffer in front of A +* + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = ERR_PRE + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 10 CONTINUE + END IF +* +* Check buffer behind A +* + IF( IPOST .GT. 0 ) THEN + J = IPRE + LDA*N + 1 + DO 20 I = J, J+IPOST-1 + IF( MEM(I) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I - J + 1 + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_POST + ERRDBUF(1, NERR) = MEM(I) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 20 CONTINUE + END IF +* +* Check all (LDA-M) gaps +* + IF( LDA .GT. M ) THEN + DO 40 J = 1, N + DO 30 I = M+1, LDA + K = IPRE + (J-1)*LDA + I + IF( MEM(K) .NE. CHECKVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_GAP + ERRDBUF(1, NERR) = MEM(K) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* Determine limits of trapezoidal matrix +* + ISTRAP = .FALSE. + IF( UPLO .EQ. 'U' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 2 + IRND = M + ICST = 1 + ICND = M - 1 + ELSEIF( M .GT. N ) THEN + IRST = ( M-N ) + 2 + IRND = M + ICST = 1 + ICND = N - 1 + ENDIF + IF( DIAG .EQ. 'U' ) THEN + IRST = IRST - 1 + ICND = ICND + 1 + ENDIF + ELSE IF( UPLO .EQ. 'L' ) THEN + ISTRAP = .TRUE. + IF( M .LE. N ) THEN + IRST = 1 + IRND = 1 + ICST = ( N-M ) + 2 + ICND = N + ELSEIF( M .GT. N ) THEN + IRST = 1 + IRND = 1 + ICST = 2 + ICND = N + ENDIF + IF( DIAG .EQ. 'U' ) THEN + ICST = ICST - 1 + ENDIF + ENDIF +* +* Check elements and report any errors +* + IF( ISTRAP ) THEN + DO 100 J = ICST, ICND + DO 105 I = IRST, IRND + IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = ERR_TRI + ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I ) + ERRDBUF(2, NERR) = CHECKVAL + END IF + END IF + 105 CONTINUE +* +* Update the limits to allow filling in padding +* + IF( UPLO .EQ. 'U' ) THEN + IRST = IRST + 1 + ELSE + IRND = IRND + 1 + ENDIF + 100 CONTINUE + END IF +* + RETURN +* +* End of ZCHKPAD. +* + END +* + SUBROUTINE ZCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, + $ MYROW, MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + CHARACTER*1 UPLO, DIAG + INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR) + DOUBLE COMPLEX A(LDA,N), ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* zCHKMAT: Check matrix to see whether there were any transmission +* errors. +* +* Arguments +* ========= +* UPLO (input) CHARACTER*1 +* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral +* rectangular? +* +* DIAG (input) CHARACTER*1 +* For trapezoidal matrices, is the main diagonal included +* ('N') or not ('U')? +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) @up@(doctype) array, dimension (LDA,N) +* The m by n matrix A. Fortran77 (column-major) storage +* assumed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1, M). +* +* RSRC (input) INTEGER +* The process row of the source of the matrix. +* +* CSRC (input) INTEGER +* The process column of the source of the matrix. +* +* MYROW (input) INTEGER +* Row of this process in the process grid. +* +* MYCOL (input) INTEGER +* Column of this process in the process grid. +* +* +* TESTNUM (input) INTEGER +* The number of the test being checked. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRZBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* =================================================================== +* +* .. Local Scalars .. + INTEGER I, J, NPROCS, SRC, DEST + LOGICAL USEIT + DOUBLE COMPLEX COMPVAL +* .. +* .. Local Arrays .. + INTEGER ISEED(4) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + DOUBLE COMPLEX ZBTRAN + EXTERNAL ZBTRAN, IBTNPROCS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + SRC = RSRC * NPROCS + CSRC + DEST = MYROW * NPROCS + MYCOL +* +* Initialize ISEED with the same values as used in ZGENMAT. +* + ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 ) + ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 ) + ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 ) + ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 ) +* +* Generate the elements randomly with the same method used in GENMAT. +* Note that for trapezoidal matrices, we generate all elements in the +* enclosing rectangle and then ignore the complementary triangle. +* + DO 100 J = 1, N + DO 105 I = 1, M + COMPVAL = ZBTRAN( ISEED ) +* +* Now determine whether we actually need this value. The +* strategy is to chop out the proper triangle based on what +* particular kind of trapezoidal matrix we're dealing with. +* + USEIT = .TRUE. + IF( UPLO .EQ. 'U' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. J ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( I .GE. M-N+J ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( I .GT. M-N+J ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + ELSE IF( UPLO .EQ. 'L' ) THEN + IF( M .LE. N ) THEN + IF( DIAG .EQ. 'U' ) THEN + IF( J. GE. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I+(N-M) ) THEN + USEIT = .FALSE. + END IF + END IF + ELSE + IF( DIAG .EQ. 'U' ) THEN + IF( J .GE. I ) THEN + USEIT = .FALSE. + END IF + ELSE + IF( J .GT. I ) THEN + USEIT = .FALSE. + END IF + END IF + END IF + END IF +* +* Compare the generated value to the one that's in the +* received matrix. If they don't match, tack another +* error record onto what's already there. +* + IF( USEIT ) THEN + IF( A(I,J) .NE. COMPVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = SRC + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I, J) + ERRDBUF(2, NERR) = COMPVAL + END IF + END IF + END IF + 105 CONTINUE + 100 CONTINUE + RETURN +* +* End of ZCHKMAT. +* + END +* + SUBROUTINE ZPRINTERRS( OUTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF, COUNTING, TFAILED ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + LOGICAL COUNTING + INTEGER OUTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), TFAILED(*) + DOUBLE COMPLEX ERRDBUF(2, MAXERR) +* .. +* +* Purpose +* ======= +* ZPRINTERRS: Print errors that have been recorded +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* Device number for output. +* +* MAXERR (input) INTEGER +* Max number of errors that can be stored in ERRIBUFF or +* ERRZBUFF +* +* NERR (output) INTEGER +* The number of errors that have been found. +* +* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS) +* Buffer in which to store integer error information. It will +* be built up in the following format for the call to TSEND. +* All integer information is recorded in the following 6-tuple +* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured: +* SRC = RSRC * NPROCS + CSRC +* DEST = RDEST * NPROCS + CDEST +* WHAT +* = 1 : Error in pre-padding +* = 2 : Error in post-padding +* = 3 : Error in LDA-M gap +* = 4 : Error in complementory triangle +* ELSE: Error in matrix +* If there are more errors than can fit in the error buffer, +* the error number will indicate the actual number of errors +* found, but the buffer will be truncated to the maximum +* number of errors which can fit. +* +* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS) +* Buffer in which to store error data information. +* {Incorrect, Predicted} +* +* TFAILED (input/ourput) INTEGER array, dimension NTESTS +* Workspace used to keep track of which tests failed. +* This array not accessed unless COUNTING is true. +* +* =================================================================== +* +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + EXTERNAL IBTMYPROC, IBTNPROCS +* .. +* .. Local Scalars .. + CHARACTER*1 MAT + LOGICAL MATISINT + INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE +* .. +* .. Executable Statements .. +* + IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN + OLDTEST = -1 + NPROCS = IBTNPROCS() + PROW = ERRIBUF(3,1) / NPROCS + PCOL = MOD( ERRIBUF(3,1), NPROCS ) + IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000) +* + DO 20 I = 1, MIN( NERR, MAXERR ) + IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN + IF( OLDTEST .NE. -1 ) + $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I) + IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1 + OLDTEST = ERRIBUF(1, I) + END IF +* +* Print out error message depending on type of error +* + ERRTYPE = ERRIBUF(6, I) + IF( ERRTYPE .LT. -10 ) THEN + ERRTYPE = -ERRTYPE - 10 + MAT = 'C' + MATISINT = .TRUE. + ELSE IF( ERRTYPE .LT. 0 ) THEN + ERRTYPE = -ERRTYPE + MAT = 'R' + MATISINT = .TRUE. + ELSE + MATISINT = .FALSE. + END IF +* +* RA/CA arrays from MAX/MIN have different printing protocol +* + IF( MATISINT ) THEN + IF( ERRIBUF(2, I) .EQ. -1 ) THEN + WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT, + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) ) + ELSE + WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I), + $ INT( ERRDBUF(2,I) ), + $ INT( ERRDBUF(1,I) ) + END IF +* +* Have memory overwrites in matrix A +* + ELSE + IF( ERRTYPE .EQ. ERR_PRE ) THEN + WRITE(OUTNUM,2000) ERRIBUF(5,I), + $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN + WRITE(OUTNUM,3000) ERRIBUF(4,I), + $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN + WRITE(OUTNUM,4000) + $ ERRIBUF(4,I), ERRIBUF(5,I), + $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) ) + ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN + WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I), + $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) ) + ELSE + WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I), + $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ), + $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) ) + END IF + END IF + 20 CONTINUE + WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST +* + 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':') + 2000 FORMAT(' Buffer overwrite ',I4, + $ ' elements before the start of A:',/, + $ ' Expected=','[',G22.16,',',G22.16,']', + $ '; Received=','[',G22.16,',',G22.16,']') + 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:', + $ /,' Expected=','[',G22.16,',',G22.16,']', + $ '; Received=','[',G22.16,',',G22.16,']') + 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/, + $ ' Expected=','[',G22.16,',',G22.16,']', + $ '; Received=','[',G22.16,',',G22.16,']') + 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4, + $ '):',/,' Expected=','[',G22.16,',',G22.16,']', + $ '; Received=','[',G22.16,',',G22.16,']') + 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/, + $ ' Expected=','[',G22.16,',',G22.16,']', + $ '; Received=','[',G22.16,',',G22.16,']') + 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) + 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ', + $ A1,'A:',/,' Expected=',I12,'; Received=',I12) +* + 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):' + $ ,/,' Expected=',I12,'; Received=',I12) +* +10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/, + $ ' Expected=',I12,'; Received=',I12) +11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent ' + $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12) +12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#', + $ I6,'.') +13000 FORMAT('WARNING: There were more errors than could be recorded.', + $ /,'Increase MEMELTS to get complete listing.') + RETURN +* +* End ZPRINTERRS +* + END +* +* + SUBROUTINE ISUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*) + INTEGER MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ITESTSUM: Test integer SUM COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* MEM (workspace) INTEGER array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, IGSUM2D + EXTERNAL IINITMAT, ICHKPAD, IBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM, + $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART, + $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA, + $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL, + $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT, + $ TESTNUM + INTEGER CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = -911 + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL IINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + CALL IGSUM2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RDEST2, + $ CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL ICHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL ICHKSUM(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL IBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('INTEGER SUM TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5) + 7000 FORMAT('INTEGER SUM TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('INTEGER SUM TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of ITESTSUM. +* + END +* + INTEGER FUNCTION IBTABS(VAL) + INTEGER VAL + IBTABS = ABS(VAL) + RETURN + END +* + SUBROUTINE ICHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, + $ NERR, ERRIBUF, ERRDBUF, ISEED ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), ISEED(*) + INTEGER A(LDA,*), ERRDBUF(2, MAXERR) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + INTEGER IBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, IBTRAN +* .. +* .. Local Scalars .. + INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST + INTEGER I, J, K + INTEGER ANS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + ANS = 0 + DO 40 K = 0, NNODES-1 + ANS = ANS + IBTRAN( ISEED(K*4+1) ) + 40 CONTINUE +* +* The error bound is figured by +* 2 * eps * (nnodes-1) * max(|max element|, |ans|). +* The 2 allows for errors in the distributed _AND_ local result. +* The eps is machine epsilon. The number of floating point adds +* is (nnodes - 1). We use the fact that 0.5 is the maximum element +* in order to save ourselves some computation. +* + IF( ANS .NE. A(I,J) ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = ANS + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of ICHKSUM +* + END +* +* + SUBROUTINE SSUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*) + REAL MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* STESTSUM: Test real SUM COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* MEM (workspace) REAL array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, SGSUM2D + EXTERNAL SINITMAT, SCHKPAD, SBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM, + $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART, + $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA, + $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL, + $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT, + $ SSIZE, TESTNUM + REAL CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = -0.61E0 + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL SINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + CALL SGSUM2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RDEST2, + $ CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL SCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL SCHKSUM(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL SBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('REAL SUM TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5) + 7000 FORMAT('REAL SUM TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('REAL SUM TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of STESTSUM. +* + END +* + REAL FUNCTION SBTABS(VAL) + REAL VAL + SBTABS = ABS(VAL) + RETURN + END +* + REAL FUNCTION SBTEPS() +* +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID + REAL SLAMCH + EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID, SLAMCH +* .. +* .. Local Scalars .. + INTEGER I, IAM, NNODES + REAL EPS, EPS2 + SAVE EPS + DATA EPS /-22.0E0/ +* .. +* .. Executable Statements .. +* +* First time called, must get max epsilon possessed by any +* participating process +* + IF( EPS .EQ. -22.0E0 ) THEN + IAM = IBTMYPROC() + NNODES = IBTNPROCS() + EPS = SLAMCH('epsilon') + IF( IAM .EQ. 0 ) THEN + IF( NNODES .GT. 1 ) THEN + DO 10 I = 1, NNODES-1 + CALL BTRECV( 4, 1, EPS2, I, IBTMSGID()+20 ) + IF( EPS .LT. EPS2 ) EPS = EPS2 + 10 CONTINUE + END IF + CALL BTSEND( 4, 1, EPS, -1, IBTMSGID()+20 ) + ELSE + CALL BTSEND( 4, 1, EPS, 0, IBTMSGID()+20 ) + CALL BTRECV( 4, 1, EPS, 0, IBTMSGID()+20 ) + ENDIF + END IF + SBTEPS = EPS + RETURN +* +* End SBTEPS +* + END +* + SUBROUTINE SCHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, + $ NERR, ERRIBUF, ERRDBUF, ISEED ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), ISEED(*) + REAL A(LDA,*), ERRDBUF(2, MAXERR) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + REAL SBTEPS + REAL SBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, SBTEPS, SBTRAN +* .. +* .. Local Scalars .. + INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST + INTEGER I, J, K + REAL ANS, EPS, ERRBND, POSNUM, NEGNUM, TMP +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = SBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + ANS = 0 + POSNUM = 0 + NEGNUM = 0 + DO 40 K = 0, NNODES-1 + TMP = SBTRAN( ISEED(K*4+1) ) + IF( TMP .LT. 0 ) THEN + NEGNUM = NEGNUM + TMP + ELSE + POSNUM = POSNUM + TMP + END IF + ANS = ANS + TMP + 40 CONTINUE +* +* The error bound is figured by +* 2 * eps * (nnodes-1) * max(|max element|, |ans|). +* The 2 allows for errors in the distributed _AND_ local result. +* The eps is machine epsilon. The number of floating point adds +* is (nnodes - 1). We use the fact that 0.5 is the maximum element +* in order to save ourselves some computation. +* + ERRBND = 2 * EPS * NNODES * MAX( POSNUM, -NEGNUM ) + IF( ABS( ANS - A(I,J) ) .GT. ERRBND ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = ANS + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of SCHKSUM +* + END +* +* + SUBROUTINE DSUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*) + DOUBLE PRECISION MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* DTESTSUM: Test double precision SUM COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, DGSUM2D + EXTERNAL DINITMAT, DCHKPAD, DBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR, ERRIPTR, I, + $ IAM, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART, + $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA, + $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL, + $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT, + $ TESTNUM + DOUBLE PRECISION CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = -0.81D0 + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + DSIZE = IBTSIZEOF('D') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL DINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + CALL DGSUM2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RDEST2, + $ CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL DCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL DCHKSUM(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL DBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE PRECISION SUM TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5) + 7000 FORMAT('DOUBLE PRECISION SUM TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('DOUBLE PRECISION SUM TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of DTESTSUM. +* + END +* + DOUBLE PRECISION FUNCTION DBTABS(VAL) + DOUBLE PRECISION VAL + DBTABS = ABS(VAL) + RETURN + END +* + DOUBLE PRECISION FUNCTION DBTEPS() +* +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID + DOUBLE PRECISION DLAMCH + EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID, DLAMCH +* .. +* .. Local Scalars .. + INTEGER I, IAM, NNODES + DOUBLE PRECISION EPS, EPS2 + SAVE EPS + DATA EPS /-22.0D0/ +* .. +* .. Executable Statements .. +* +* First time called, must get max epsilon possessed by any +* participating process +* + IF( EPS .EQ. -22.0D0 ) THEN + IAM = IBTMYPROC() + NNODES = IBTNPROCS() + EPS = DLAMCH('epsilon') + IF( IAM .EQ. 0 ) THEN + IF( NNODES .GT. 1 ) THEN + DO 10 I = 1, NNODES-1 + CALL BTRECV( 6, 1, EPS2, I, IBTMSGID()+20 ) + IF( EPS .LT. EPS2 ) EPS = EPS2 + 10 CONTINUE + END IF + CALL BTSEND( 6, 1, EPS, -1, IBTMSGID()+20 ) + ELSE + CALL BTSEND( 6, 1, EPS, 0, IBTMSGID()+20 ) + CALL BTRECV( 6, 1, EPS, 0, IBTMSGID()+20 ) + ENDIF + END IF + DBTEPS = EPS + RETURN +* +* End DBTEPS +* + END +* + SUBROUTINE DCHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, + $ NERR, ERRIBUF, ERRDBUF, ISEED ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), ISEED(*) + DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + DOUBLE PRECISION DBTEPS + DOUBLE PRECISION DBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, DBTEPS, DBTRAN +* .. +* .. Local Scalars .. + INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST + INTEGER I, J, K + DOUBLE PRECISION ANS, EPS, ERRBND, POSNUM, NEGNUM, TMP +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = DBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + ANS = 0 + POSNUM = 0 + NEGNUM = 0 + DO 40 K = 0, NNODES-1 + TMP = DBTRAN( ISEED(K*4+1) ) + IF( TMP .LT. 0 ) THEN + NEGNUM = NEGNUM + TMP + ELSE + POSNUM = POSNUM + TMP + END IF + ANS = ANS + TMP + 40 CONTINUE +* +* The error bound is figured by +* 2 * eps * (nnodes-1) * max(|max element|, |ans|). +* The 2 allows for errors in the distributed _AND_ local result. +* The eps is machine epsilon. The number of floating point adds +* is (nnodes - 1). We use the fact that 0.5 is the maximum element +* in order to save ourselves some computation. +* + ERRBND = 2 * EPS * NNODES * MAX( POSNUM, -NEGNUM ) + IF( ABS( ANS - A(I,J) ) .GT. ERRBND ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = ANS + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of DCHKSUM +* + END +* +* + SUBROUTINE CSUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*) + COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* CTESTSUM: Test complex SUM COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* MEM (workspace) COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, CGSUM2D + EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR, ERRIPTR, I, + $ IAM, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART, + $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA, + $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL, + $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT, + $ TESTNUM + COMPLEX CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = CMPLX( -0.91E0, -0.71E0 ) + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + CSIZE = IBTSIZEOF('C') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL CINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + CALL CGSUM2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RDEST2, + $ CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL CCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL CCHKSUM(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL CBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('COMPLEX SUM TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5) + 7000 FORMAT('COMPLEX SUM TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('COMPLEX SUM TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of CTESTSUM. +* + END +* + REAL FUNCTION CBTABS(VAL) + COMPLEX VAL + CBTABS = ABS( REAL(VAL) ) + ABS( AIMAG(VAL) ) + RETURN + END +* + SUBROUTINE CCHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, + $ NERR, ERRIBUF, ERRDBUF, ISEED ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), ISEED(*) + COMPLEX A(LDA,*), ERRDBUF(2, MAXERR) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + REAL SBTEPS + COMPLEX CBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, SBTEPS, CBTRAN +* .. +* .. Local Scalars .. + LOGICAL NUMOK + INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST + INTEGER I, J, K + COMPLEX ANS, TMP + REAL EPS, ERRBND, RPOSNUM, RNEGNUM, IPOSNUM, INEGNUM +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = SBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + ANS = 0 + RPOSNUM = 0 + RNEGNUM = 0 + IPOSNUM = 0 + INEGNUM = 0 + DO 40 K = 0, NNODES-1 + TMP = CBTRAN( ISEED(K*4+1) ) + IF( REAL( TMP ) .LT. 0 ) THEN + RNEGNUM = RNEGNUM + REAL( TMP ) + ELSE + RPOSNUM = RPOSNUM + REAL( TMP ) + END IF + IF( AIMAG( TMP ) .LT. 0 ) THEN + INEGNUM = INEGNUM + AIMAG( TMP ) + ELSE + IPOSNUM = IPOSNUM + AIMAG( TMP ) + END IF + ANS = ANS + TMP + 40 CONTINUE +* +* The error bound is figured by +* 2 * eps * (nnodes-1) * max(|max element|, |ans|). +* The 2 allows for errors in the distributed _AND_ local result. +* The eps is machine epsilon. The number of floating point adds +* is (nnodes - 1). We use the fact that 0.5 is the maximum element +* in order to save ourselves some computation. +* + TMP = ANS - A(I,J) + ERRBND = 2 * EPS * NNODES * MAX( RPOSNUM, -RNEGNUM ) + NUMOK = ( REAL(TMP) .LE. ERRBND ) + ERRBND = 2 * EPS * NNODES * MAX( IPOSNUM, -INEGNUM ) + NUMOK = NUMOK .AND. ( AIMAG(TMP) .LE. ERRBND ) + IF( .NOT.NUMOK ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = ANS + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of CCHKSUM +* + END +* +* + SUBROUTINE ZSUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*) + DOUBLE COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ZTESTSUM: Test double complex SUM COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, ZGSUM2D + EXTERNAL ZINITMAT, ZCHKPAD, ZBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM, + $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART, + $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA, + $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL, + $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT, + $ TESTNUM, ZSIZE + DOUBLE COMPLEX CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = DCMPLX( -9.11D0, -9.21D0 ) + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + ZSIZE = IBTSIZEOF('Z') +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL ZINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* + CALL ZGSUM2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RDEST2, + $ CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL ZCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL ZCHKSUM(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL ZBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE COMPLEX SUM TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5) + 7000 FORMAT('DOUBLE COMPLEX SUM TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('DOUBLE COMPLEX SUM TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of ZTESTSUM. +* + END +* + DOUBLE PRECISION FUNCTION ZBTABS(VAL) + DOUBLE COMPLEX VAL + ZBTABS = ABS( DBLE(VAL) ) + ABS( DIMAG(VAL) ) + RETURN + END +* + SUBROUTINE ZCHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, + $ NERR, ERRIBUF, ERRDBUF, ISEED ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER ERRIBUF(6, MAXERR), ISEED(*) + DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS + DOUBLE PRECISION DBTEPS + DOUBLE COMPLEX ZBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, DBTEPS, ZBTRAN +* .. +* .. Local Scalars .. + LOGICAL NUMOK + INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST + INTEGER I, J, K + DOUBLE COMPLEX ANS, TMP + DOUBLE PRECISION EPS, ERRBND, RPOSNUM, RNEGNUM, IPOSNUM, INEGNUM +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = DBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + ANS = 0 + RPOSNUM = 0 + RNEGNUM = 0 + IPOSNUM = 0 + INEGNUM = 0 + DO 40 K = 0, NNODES-1 + TMP = ZBTRAN( ISEED(K*4+1) ) + IF( DBLE( TMP ) .LT. 0 ) THEN + RNEGNUM = RNEGNUM + DBLE( TMP ) + ELSE + RPOSNUM = RPOSNUM + DBLE( TMP ) + END IF + IF( DIMAG( TMP ) .LT. 0 ) THEN + INEGNUM = INEGNUM + DIMAG( TMP ) + ELSE + IPOSNUM = IPOSNUM + DIMAG( TMP ) + END IF + ANS = ANS + TMP + 40 CONTINUE +* +* The error bound is figured by +* 2 * eps * (nnodes-1) * max(|max element|, |ans|). +* The 2 allows for errors in the distributed _AND_ local result. +* The eps is machine epsilon. The number of floating point adds +* is (nnodes - 1). We use the fact that 0.5 is the maximum element +* in order to save ourselves some computation. +* + TMP = ANS - A(I,J) + ERRBND = 2 * EPS * NNODES * MAX( RPOSNUM, -RNEGNUM ) + NUMOK = ( DBLE(TMP) .LE. ERRBND ) + ERRBND = 2 * EPS * NNODES * MAX( IPOSNUM, -INEGNUM ) + NUMOK = NUMOK .AND. ( DIMAG(TMP) .LE. ERRBND ) + IF( .NOT.NUMOK ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = ANS + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of ZCHKSUM +* + END +* +* + SUBROUTINE IAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + INTEGER MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ITESTAMX: Test integer AMX COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) INTEGER array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, IGAMX2D + EXTERNAL IINITMAT, ICHKPAD, IBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, + $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, + $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, + $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL, + $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR, + $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR + INTEGER CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = -911 + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL IINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL IGAMX2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL ICHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL ICHKAMX(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL IRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL IBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('INTEGER AMX TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('INTEGER AMX TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('INTEGER AMX TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of ITESTAMX. +* + END +* + SUBROUTINE IBTSPCOORD( SCOPE, PNUM, MYROW, MYCOL, NPCOL, + $ PROW, PCOL ) + CHARACTER*1 SCOPE + INTEGER PNUM, MYROW, MYCOL, NPCOL, PROW, PCOL +* + IF( SCOPE .EQ. 'R' ) THEN + PROW = MYROW + PCOL = PNUM + ELSE IF( SCOPE .EQ. 'C' ) THEN + PROW = PNUM + PCOL = MYCOL + ELSE + PROW = PNUM / NPCOL + PCOL = MOD( PNUM, NPCOL ) + END IF + RETURN +* +* End of ibtspcoord +* + END +* + INTEGER FUNCTION IBTSPNUM( SCOPE, PROW, PCOL, NPCOL ) + CHARACTER*1 SCOPE + INTEGER PROW, PCOL, NPCOL + IF( SCOPE .EQ. 'R' ) THEN + IBTSPNUM = PCOL + ELSE IF( SCOPE .EQ. 'C' ) THEN + IBTSPNUM = PROW + ELSE + IBTSPNUM = PROW*NPCOL + PCOL + END IF +* + RETURN +* +* End of ibtscpnum +* + END +* + SUBROUTINE IRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, + $ MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* .. Scalar Arguments .. + INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR) + INTEGER ERRDBUF(2, MAXERR) +* .. +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, K, IAM +* .. +* .. Executable Statements .. +* + IAM = MYROW * IBTNPROCS() + MYCOL +* +* Check pre padding +* + IF( LDI .NE. -1 ) THEN + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = INT( RA(I) ) + ERRDBUF(2, NERR) = INT( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = INT( CA(I) ) + ERRDBUF(2, NERR) = INT( PADVAL ) + END IF + ENDIF + 10 CONTINUE + END IF +* +* Check post padding +* + IF( IPOST .GT. 0 ) THEN + K = IPRE + LDI*N + DO 20 I = K+1, K+IPOST + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -ERR_POST + ERRDBUF(1, NERR) = INT( RA(I) ) + ERRDBUF(2, NERR) = INT( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -10 - ERR_POST + ERRDBUF(1, NERR) = INT( CA(I) ) + ERRDBUF(2, NERR) = INT( PADVAL ) + END IF + ENDIF + 20 CONTINUE + END IF +* +* Check all (LDI-M) gaps +* + IF( LDI .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = M+1, LDI + K = IPRE + (J-1)*LDI + I + IF( RA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -ERR_GAP + ERRDBUF(1, NERR) = INT( RA(K) ) + ERRDBUF(2, NERR) = INT( PADVAL ) + END IF + END IF + IF( CA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -10 - ERR_GAP + ERRDBUF(1, NERR) = INT( CA(K) ) + ERRDBUF(2, NERR) = INT( PADVAL ) + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* if RA and CA don't exist, buffs better be untouched +* + ELSE + DO 50 I = 1, IPRE+IPOST + IF( RA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = INT( RA(I) ) + ERRDBUF(2, NERR) = INT( PADVAL ) + END IF + END IF + IF( CA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = INT( CA(I) ) + ERRDBUF(2, NERR) = INT( PADVAL ) + END IF + END IF + 50 CONTINUE + ENDIF +* + RETURN + END +* + SUBROUTINE ICHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + INTEGER A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN, IBTABS + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN + EXTERNAL IBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX + INTEGER IAMX, I, J, K, H, DEST, NODE +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = IBTRAN( ISEED ) + IAMX = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = IBTRAN( ISEED(K*4+1) ) + IF( IBTABS( VALS(K+1) ) .GT. IBTABS( VALS(IAMX) ) ) + $ IAMX = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMX) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = IBTABS( VALS(K) ).NE.IBTABS( VALS(IAMX) ) + IF( .NOT.ERROR ) IAMX = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ( IBTABS( A(I,J) ) .NE. IBTABS( VALS(IAMX) ) ) + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMX) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMX ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMX) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL, + $ NPCOL, RAMX, CAMX ) + IF( RAMX .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMX + END IF + IF( CAMX .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMX + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of ICHKAMX +* + END +* +* + SUBROUTINE SAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + REAL MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* STESTAMX: Test real AMX COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) REAL array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, SGAMX2D + EXTERNAL SINITMAT, SCHKPAD, SBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, + $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, + $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, + $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL, + $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR, + $ RAPTR, RDEST, RDEST2, SETWHAT, SSIZE, TESTNUM, VALPTR + REAL CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = -0.61E0 + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL SINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL SGAMX2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL SCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL SCHKAMX(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL SRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL SBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('REAL AMX TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('REAL AMX TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('REAL AMX TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of STESTAMX. +* + END +* + SUBROUTINE SRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, + $ MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* .. Scalar Arguments .. + INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR) + REAL ERRDBUF(2, MAXERR) +* .. +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, K, IAM +* .. +* .. Executable Statements .. +* + IAM = MYROW * IBTNPROCS() + MYCOL +* +* Check pre padding +* + IF( LDI .NE. -1 ) THEN + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = REAL( RA(I) ) + ERRDBUF(2, NERR) = REAL( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = REAL( CA(I) ) + ERRDBUF(2, NERR) = REAL( PADVAL ) + END IF + ENDIF + 10 CONTINUE + END IF +* +* Check post padding +* + IF( IPOST .GT. 0 ) THEN + K = IPRE + LDI*N + DO 20 I = K+1, K+IPOST + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -ERR_POST + ERRDBUF(1, NERR) = REAL( RA(I) ) + ERRDBUF(2, NERR) = REAL( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -10 - ERR_POST + ERRDBUF(1, NERR) = REAL( CA(I) ) + ERRDBUF(2, NERR) = REAL( PADVAL ) + END IF + ENDIF + 20 CONTINUE + END IF +* +* Check all (LDI-M) gaps +* + IF( LDI .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = M+1, LDI + K = IPRE + (J-1)*LDI + I + IF( RA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -ERR_GAP + ERRDBUF(1, NERR) = REAL( RA(K) ) + ERRDBUF(2, NERR) = REAL( PADVAL ) + END IF + END IF + IF( CA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -10 - ERR_GAP + ERRDBUF(1, NERR) = REAL( CA(K) ) + ERRDBUF(2, NERR) = REAL( PADVAL ) + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* if RA and CA don't exist, buffs better be untouched +* + ELSE + DO 50 I = 1, IPRE+IPOST + IF( RA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = REAL( RA(I) ) + ERRDBUF(2, NERR) = REAL( PADVAL ) + END IF + END IF + IF( CA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = REAL( CA(I) ) + ERRDBUF(2, NERR) = REAL( PADVAL ) + END IF + END IF + 50 CONTINUE + ENDIF +* + RETURN + END +* + SUBROUTINE SCHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + REAL A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM + REAL SBTEPS, SBTABS + REAL SBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, SBTRAN, SBTEPS, SBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX + INTEGER IAMX, I, J, K, H, DEST, NODE + REAL EPS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = SBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = SBTRAN( ISEED ) + IAMX = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = SBTRAN( ISEED(K*4+1) ) + IF( SBTABS( VALS(K+1) ) .GT. SBTABS( VALS(IAMX) ) ) + $ IAMX = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMX) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = SBTABS( VALS(K) ).NE.SBTABS( VALS(IAMX) ) + IF( .NOT.ERROR ) IAMX = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ( SBTABS( A(I,J) ) .NE. SBTABS( VALS(IAMX) ) ) + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMX) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMX ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMX) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL, + $ NPCOL, RAMX, CAMX ) + IF( RAMX .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMX + END IF + IF( CAMX .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMX + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of SCHKAMX +* + END +* +* + SUBROUTINE DAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + DOUBLE PRECISION MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* DTESTAMX: Test double precision AMX COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, DGAMX2D + EXTERNAL DINITMAT, DCHKPAD, DBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR, + $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, + $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, + $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, + $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, + $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR + DOUBLE PRECISION CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = -0.81D0 + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + DSIZE = IBTSIZEOF('D') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL DINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL DGAMX2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL DCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL DCHKAMX(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL DRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL DBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE PRECISION AMX TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('DOUBLE PRECISION AMX TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('DOUBLE PRECISION AMX TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of DTESTAMX. +* + END +* + SUBROUTINE DRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, + $ MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* .. Scalar Arguments .. + INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR) + DOUBLE PRECISION ERRDBUF(2, MAXERR) +* .. +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, K, IAM +* .. +* .. Executable Statements .. +* + IAM = MYROW * IBTNPROCS() + MYCOL +* +* Check pre padding +* + IF( LDI .NE. -1 ) THEN + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = DBLE( RA(I) ) + ERRDBUF(2, NERR) = DBLE( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = DBLE( CA(I) ) + ERRDBUF(2, NERR) = DBLE( PADVAL ) + END IF + ENDIF + 10 CONTINUE + END IF +* +* Check post padding +* + IF( IPOST .GT. 0 ) THEN + K = IPRE + LDI*N + DO 20 I = K+1, K+IPOST + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -ERR_POST + ERRDBUF(1, NERR) = DBLE( RA(I) ) + ERRDBUF(2, NERR) = DBLE( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -10 - ERR_POST + ERRDBUF(1, NERR) = DBLE( CA(I) ) + ERRDBUF(2, NERR) = DBLE( PADVAL ) + END IF + ENDIF + 20 CONTINUE + END IF +* +* Check all (LDI-M) gaps +* + IF( LDI .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = M+1, LDI + K = IPRE + (J-1)*LDI + I + IF( RA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -ERR_GAP + ERRDBUF(1, NERR) = DBLE( RA(K) ) + ERRDBUF(2, NERR) = DBLE( PADVAL ) + END IF + END IF + IF( CA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -10 - ERR_GAP + ERRDBUF(1, NERR) = DBLE( CA(K) ) + ERRDBUF(2, NERR) = DBLE( PADVAL ) + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* if RA and CA don't exist, buffs better be untouched +* + ELSE + DO 50 I = 1, IPRE+IPOST + IF( RA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = DBLE( RA(I) ) + ERRDBUF(2, NERR) = DBLE( PADVAL ) + END IF + END IF + IF( CA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = DBLE( CA(I) ) + ERRDBUF(2, NERR) = DBLE( PADVAL ) + END IF + END IF + 50 CONTINUE + ENDIF +* + RETURN + END +* + SUBROUTINE DCHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM + DOUBLE PRECISION DBTEPS, DBTABS + DOUBLE PRECISION DBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, DBTRAN, DBTEPS, DBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX + INTEGER IAMX, I, J, K, H, DEST, NODE + DOUBLE PRECISION EPS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = DBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = DBTRAN( ISEED ) + IAMX = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = DBTRAN( ISEED(K*4+1) ) + IF( DBTABS( VALS(K+1) ) .GT. DBTABS( VALS(IAMX) ) ) + $ IAMX = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMX) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = DBTABS( VALS(K) ).NE.DBTABS( VALS(IAMX) ) + IF( .NOT.ERROR ) IAMX = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ( DBTABS( A(I,J) ) .NE. DBTABS( VALS(IAMX) ) ) + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMX) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMX ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMX) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL, + $ NPCOL, RAMX, CAMX ) + IF( RAMX .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMX + END IF + IF( CAMX .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMX + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of DCHKAMX +* + END +* +* + SUBROUTINE CAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* CTESTAMX: Test complex AMX COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, CGAMX2D + EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR, + $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, + $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, + $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, + $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, + $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR + COMPLEX CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = CMPLX( -0.91E0, -0.71E0 ) + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + CSIZE = IBTSIZEOF('C') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL CINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL CGAMX2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL CCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL CCHKAMX(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL CRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL CBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('COMPLEX AMX TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('COMPLEX AMX TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('COMPLEX AMX TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of CTESTAMX. +* + END +* + SUBROUTINE CRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, + $ MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* .. Scalar Arguments .. + INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR) + COMPLEX ERRDBUF(2, MAXERR) +* .. +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, K, IAM +* .. +* .. Executable Statements .. +* + IAM = MYROW * IBTNPROCS() + MYCOL +* +* Check pre padding +* + IF( LDI .NE. -1 ) THEN + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = CMPLX( RA(I) ) + ERRDBUF(2, NERR) = CMPLX( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = CMPLX( CA(I) ) + ERRDBUF(2, NERR) = CMPLX( PADVAL ) + END IF + ENDIF + 10 CONTINUE + END IF +* +* Check post padding +* + IF( IPOST .GT. 0 ) THEN + K = IPRE + LDI*N + DO 20 I = K+1, K+IPOST + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -ERR_POST + ERRDBUF(1, NERR) = CMPLX( RA(I) ) + ERRDBUF(2, NERR) = CMPLX( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -10 - ERR_POST + ERRDBUF(1, NERR) = CMPLX( CA(I) ) + ERRDBUF(2, NERR) = CMPLX( PADVAL ) + END IF + ENDIF + 20 CONTINUE + END IF +* +* Check all (LDI-M) gaps +* + IF( LDI .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = M+1, LDI + K = IPRE + (J-1)*LDI + I + IF( RA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -ERR_GAP + ERRDBUF(1, NERR) = CMPLX( RA(K) ) + ERRDBUF(2, NERR) = CMPLX( PADVAL ) + END IF + END IF + IF( CA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -10 - ERR_GAP + ERRDBUF(1, NERR) = CMPLX( CA(K) ) + ERRDBUF(2, NERR) = CMPLX( PADVAL ) + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* if RA and CA don't exist, buffs better be untouched +* + ELSE + DO 50 I = 1, IPRE+IPOST + IF( RA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = CMPLX( RA(I) ) + ERRDBUF(2, NERR) = CMPLX( PADVAL ) + END IF + END IF + IF( CA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = CMPLX( CA(I) ) + ERRDBUF(2, NERR) = CMPLX( PADVAL ) + END IF + END IF + 50 CONTINUE + ENDIF +* + RETURN + END +* + SUBROUTINE CCHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM + REAL SBTEPS, CBTABS + COMPLEX CBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, CBTRAN, SBTEPS, CBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX + INTEGER IAMX, I, J, K, H, DEST, NODE + REAL EPS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = SBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = CBTRAN( ISEED ) + IAMX = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = CBTRAN( ISEED(K*4+1) ) + IF( CBTABS( VALS(K+1) ) .GT. CBTABS( VALS(IAMX) ) ) + $ IAMX = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMX) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = ABS( CBTABS(VALS(K)) - CBTABS(VALS(IAMX)) ) + $ .GT. 3*EPS + IF( .NOT.ERROR ) IAMX = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ABS( CBTABS(A(I,J)) - CBTABS(VALS(IAMX)) ) + $ .GT. 3*EPS + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMX) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMX ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMX) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL, + $ NPCOL, RAMX, CAMX ) + IF( RAMX .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMX + END IF + IF( CAMX .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMX + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of CCHKAMX +* + END +* +* + SUBROUTINE ZAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + DOUBLE COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ZTESTAMX: Test double complex AMX COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, ZGAMX2D + EXTERNAL ZINITMAT, ZCHKPAD, ZBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, + $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, + $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, + $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL, + $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR, + $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR, ZSIZE + DOUBLE COMPLEX CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = DCMPLX( -9.11D0, -9.21D0 ) + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + ZSIZE = IBTSIZEOF('Z') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL ZINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL ZGAMX2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL ZCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL ZCHKAMX(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL ZRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL ZBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE COMPLEX AMX TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('DOUBLE COMPLEX AMX TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('DOUBLE COMPLEX AMX TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of ZTESTAMX. +* + END +* + SUBROUTINE ZRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, + $ MYCOL, TESTNUM, MAXERR, NERR, + $ ERRIBUF, ERRDBUF ) +* +* .. Scalar Arguments .. + INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM + INTEGER MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR) + DOUBLE COMPLEX ERRDBUF(2, MAXERR) +* .. +* .. Parameters .. + INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT + PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 ) + PARAMETER( ERR_MAT = 5 ) +* .. +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Local Scalars .. + INTEGER I, J, K, IAM +* .. +* .. Executable Statements .. +* + IAM = MYROW * IBTNPROCS() + MYCOL +* +* Check pre padding +* + IF( LDI .NE. -1 ) THEN + IF( IPRE .GT. 0 ) THEN + DO 10 I = 1, IPRE + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = DCMPLX( RA(I) ) + ERRDBUF(2, NERR) = DCMPLX( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE - I + 1 + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = DCMPLX( CA(I) ) + ERRDBUF(2, NERR) = DCMPLX( PADVAL ) + END IF + ENDIF + 10 CONTINUE + END IF +* +* Check post padding +* + IF( IPOST .GT. 0 ) THEN + K = IPRE + LDI*N + DO 20 I = K+1, K+IPOST + IF( RA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -ERR_POST + ERRDBUF(1, NERR) = DCMPLX( RA(I) ) + ERRDBUF(2, NERR) = DCMPLX( PADVAL ) + END IF + ENDIF + IF( CA(I) .NE. PADVAL ) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I - K + ERRIBUF(5, NERR) = I + ERRIBUF(6, NERR) = -10 - ERR_POST + ERRDBUF(1, NERR) = DCMPLX( CA(I) ) + ERRDBUF(2, NERR) = DCMPLX( PADVAL ) + END IF + ENDIF + 20 CONTINUE + END IF +* +* Check all (LDI-M) gaps +* + IF( LDI .GT. M ) THEN + K = IPRE + M + 1 + DO 40 J = 1, N + DO 30 I = M+1, LDI + K = IPRE + (J-1)*LDI + I + IF( RA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -ERR_GAP + ERRDBUF(1, NERR) = DCMPLX( RA(K) ) + ERRDBUF(2, NERR) = DCMPLX( PADVAL ) + END IF + END IF + IF( CA(K) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -10 - ERR_GAP + ERRDBUF(1, NERR) = DCMPLX( CA(K) ) + ERRDBUF(2, NERR) = DCMPLX( PADVAL ) + END IF + END IF + 30 CONTINUE + 40 CONTINUE + END IF +* +* if RA and CA don't exist, buffs better be untouched +* + ELSE + DO 50 I = 1, IPRE+IPOST + IF( RA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -ERR_PRE + ERRDBUF(1, NERR) = DCMPLX( RA(I) ) + ERRDBUF(2, NERR) = DCMPLX( PADVAL ) + END IF + END IF + IF( CA(I) .NE. PADVAL) THEN + NERR = NERR + 1 + IF( NERR .LE. MAXERR ) THEN + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = LDI + ERRIBUF(3, NERR) = IAM + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = IPRE+IPOST + ERRIBUF(6, NERR) = -10 - ERR_PRE + ERRDBUF(1, NERR) = DCMPLX( CA(I) ) + ERRDBUF(2, NERR) = DCMPLX( PADVAL ) + END IF + END IF + 50 CONTINUE + ENDIF +* + RETURN + END +* + SUBROUTINE ZCHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM + DOUBLE PRECISION DBTEPS, ZBTABS + DOUBLE COMPLEX ZBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, ZBTRAN, DBTEPS, ZBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX + INTEGER IAMX, I, J, K, H, DEST, NODE + DOUBLE PRECISION EPS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = DBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = ZBTRAN( ISEED ) + IAMX = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = ZBTRAN( ISEED(K*4+1) ) + IF( ZBTABS( VALS(K+1) ) .GT. ZBTABS( VALS(IAMX) ) ) + $ IAMX = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMX) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = ABS( ZBTABS(VALS(K)) - ZBTABS(VALS(IAMX)) ) + $ .GT. 3*EPS + IF( .NOT.ERROR ) IAMX = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ABS( ZBTABS(A(I,J)) - ZBTABS(VALS(IAMX)) ) + $ .GT. 3*EPS + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMX) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMX ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMX) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL, + $ NPCOL, RAMX, CAMX ) + IF( RAMX .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMX + END IF + IF( CAMX .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMX + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of ZCHKAMX +* + END +* +* + SUBROUTINE IAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + INTEGER MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ITESTAMN: Test integer AMN COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) INTEGER array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, IGAMN2D + EXTERNAL IINITMAT, ICHKPAD, IBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, + $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, + $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, + $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL, + $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR, + $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR + INTEGER CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = -911 + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL IINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL IGAMN2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL ICHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL ICHKAMN(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL IRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL IBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('INTEGER AMN TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('INTEGER AMN TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('INTEGER AMN TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of ITESTAMN. +* + END +* + SUBROUTINE ICHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + INTEGER A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN, IBTABS + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN + EXTERNAL IBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN + INTEGER IAMN, I, J, K, H, DEST, NODE +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = IBTRAN( ISEED ) + IAMN = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = IBTRAN( ISEED(K*4+1) ) + IF( IBTABS( VALS(K+1) ) .LT. IBTABS( VALS(IAMN) ) ) + $ IAMN = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMN) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = IBTABS( VALS(K) ).NE.IBTABS( VALS(IAMN) ) + IF( .NOT.ERROR ) IAMN = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ( IBTABS( A(I,J) ) .NE. IBTABS( VALS(IAMN) ) ) + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMN) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMN ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMN) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL, + $ NPCOL, RAMN, CAMN ) + IF( RAMN .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMN + END IF + IF( CAMN .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMN + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of ICHKAMN +* + END +* +* + SUBROUTINE SAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + REAL MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* STESTAMN: Test real AMN COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) REAL array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, SGAMN2D + EXTERNAL SINITMAT, SCHKPAD, SBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, + $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, + $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, + $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL, + $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR, + $ RAPTR, RDEST, RDEST2, SETWHAT, SSIZE, TESTNUM, VALPTR + REAL CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = -0.61E0 + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL SINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL SGAMN2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL SCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL SCHKAMN(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL SRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL SBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('REAL AMN TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('REAL AMN TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('REAL AMN TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of STESTAMN. +* + END +* + SUBROUTINE SCHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + REAL A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM + REAL SBTEPS, SBTABS + REAL SBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, SBTRAN, SBTEPS, SBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN + INTEGER IAMN, I, J, K, H, DEST, NODE + REAL EPS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = SBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = SBTRAN( ISEED ) + IAMN = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = SBTRAN( ISEED(K*4+1) ) + IF( SBTABS( VALS(K+1) ) .LT. SBTABS( VALS(IAMN) ) ) + $ IAMN = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMN) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = SBTABS( VALS(K) ).NE.SBTABS( VALS(IAMN) ) + IF( .NOT.ERROR ) IAMN = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ( SBTABS( A(I,J) ) .NE. SBTABS( VALS(IAMN) ) ) + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMN) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMN ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMN) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL, + $ NPCOL, RAMN, CAMN ) + IF( RAMN .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMN + END IF + IF( CAMN .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMN + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of SCHKAMN +* + END +* +* + SUBROUTINE DAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + DOUBLE PRECISION MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* DTESTAMN: Test double precision AMN COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, DGAMN2D + EXTERNAL DINITMAT, DCHKPAD, DBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR, + $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, + $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, + $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, + $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, + $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR + DOUBLE PRECISION CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = -0.81D0 + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + DSIZE = IBTSIZEOF('D') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL DINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL DGAMN2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL DCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL DCHKAMN(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL DRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL DBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE PRECISION AMN TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('DOUBLE PRECISION AMN TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('DOUBLE PRECISION AMN TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of DTESTAMN. +* + END +* + SUBROUTINE DCHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM + DOUBLE PRECISION DBTEPS, DBTABS + DOUBLE PRECISION DBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, DBTRAN, DBTEPS, DBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN + INTEGER IAMN, I, J, K, H, DEST, NODE + DOUBLE PRECISION EPS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = DBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = DBTRAN( ISEED ) + IAMN = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = DBTRAN( ISEED(K*4+1) ) + IF( DBTABS( VALS(K+1) ) .LT. DBTABS( VALS(IAMN) ) ) + $ IAMN = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMN) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = DBTABS( VALS(K) ).NE.DBTABS( VALS(IAMN) ) + IF( .NOT.ERROR ) IAMN = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ( DBTABS( A(I,J) ) .NE. DBTABS( VALS(IAMN) ) ) + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMN) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMN ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMN) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL, + $ NPCOL, RAMN, CAMN ) + IF( RAMN .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMN + END IF + IF( CAMN .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMN + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of DCHKAMN +* + END +* +* + SUBROUTINE CAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* CTESTAMN: Test complex AMN COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, CGAMN2D + EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR, + $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, + $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, + $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, + $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, + $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR + COMPLEX CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = CMPLX( -0.91E0, -0.71E0 ) + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + CSIZE = IBTSIZEOF('C') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL CINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL CGAMN2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL CCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL CCHKAMN(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL CRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL CBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('COMPLEX AMN TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('COMPLEX AMN TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('COMPLEX AMN TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of CTESTAMN. +* + END +* + SUBROUTINE CCHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM + REAL SBTEPS, CBTABS + COMPLEX CBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, CBTRAN, SBTEPS, CBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN + INTEGER IAMN, I, J, K, H, DEST, NODE + REAL EPS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = SBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = CBTRAN( ISEED ) + IAMN = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = CBTRAN( ISEED(K*4+1) ) + IF( CBTABS( VALS(K+1) ) .LT. CBTABS( VALS(IAMN) ) ) + $ IAMN = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMN) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = ABS( CBTABS(VALS(K)) - CBTABS(VALS(IAMN)) ) + $ .GT. 3*EPS + IF( .NOT.ERROR ) IAMN = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ABS( CBTABS(A(I,J)) - CBTABS(VALS(IAMN)) ) + $ .GT. 3*EPS + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMN) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMN ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMN) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL, + $ NPCOL, RAMN, CAMN ) + IF( RAMN .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMN + END IF + IF( CAMN .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMN + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of CCHKAMN +* + END +* +* + SUBROUTINE ZAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, + $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, + $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, + $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, + $ MEM, MEMLEN ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN, + $ TOPSCOHRNT, TOPSREPEAT, VERB +* .. +* .. Array Arguments .. + CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP) + INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT) + INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID) + INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN) + DOUBLE COMPLEX MEM(MEMLEN) +* .. +* +* Purpose +* ======= +* ZTESTAMN: Test double complex AMN COMBINE +* +* Arguments +* ========= +* OUTNUM (input) INTEGER +* The device number to write output to. +* +* VERB (input) INTEGER +* The level of verbosity (how much printing to do). +* +* NSCOPE (input) INTEGER +* The number of scopes to be tested. +* +* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE) +* Values of the scopes to be tested. +* +* NTOP (input) INTEGER +* The number of topologies to be tested. +* +* TOP0 (input) CHARACTER*1 array of dimension (NTOP) +* Values of the topologies to be tested. +* +* NMAT (input) INTEGER +* The number of matrices to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* M0 (input) INTEGER array of dimension (NMAT) +* Values of M to be tested. +* +* N0 (input) INTEGER array of dimension (NMAT) +* Values of N to be tested. +* +* LDAS0 (input) INTEGER array of dimension (NMAT) +* Values of LDAS (leading dimension of A on source process) +* to be tested. +* +* LDAD0 (input) INTEGER array of dimension (NMAT) +* Values of LDAD (leading dimension of A on destination +* process) to be tested. +* LDI0 (input) INTEGER array of dimension (NMAT) +* Values of LDI (leading dimension of RA/CA) to be tested. +* If LDI == -1, these RA/CA should not be accessed. +* +* NDEST (input) INTEGER +* The number of destinations to be tested. +* +* RDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of RDEST (row coordinate of destination) to be +* tested. +* +* CDEST0 (input) INTEGER array of dimension (NNDEST) +* Values of CDEST (column coordinate of destination) to be +* tested. +* +* NGRID (input) INTEGER +* The number of process grids to be tested. +* +* CONTEXT0 (input) INTEGER array of dimension (NGRID) +* The BLACS context handles corresponding to the grids. +* +* P0 (input) INTEGER array of dimension (NGRID) +* Values of P (number of process rows, NPROW). +* +* Q0 (input) INTEGER array of dimension (NGRID) +* Values of Q (number of process columns, NPCOL). +* +* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) ) +* Workspace used to hold each process's random number SEED. +* This requires NPROCS (number of processor) elements. +* If VERB < 2, this workspace also serves to indicate which +* tests fail. This requires workspace of NTESTS +* (number of tests performed). +* +* RMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all RA arrays, and their pre and post padding. +* +* CMEM (workspace) INTEGER array of dimension (RCLEN) +* Used for all CA arrays, and their pre and post padding. +* +* RCLEN (input) INTEGER +* The length, in elements, of RMEM and CMEM. +* +* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN) +* Used for all other workspaces, including the matrix A, +* and its pre and post padding. +* +* MEMLEN (input) INTEGER +* The length, in elements, of MEM. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL ALLPASS, LSAME + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. External Subroutines .. + EXTERNAL BLACS_GRIDINFO, ZGAMN2D + EXTERNAL ZINITMAT, ZCHKPAD, ZBTCHECKIN +* .. +* .. Local Scalars .. + CHARACTER*1 SCOPE, TOP + LOGICAL INGRID, TESTOK, ALLRCV + INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, + $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, + $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, + $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL, + $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR, + $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR, ZSIZE + DOUBLE COMPLEX CHECKVAL +* .. +* .. Executable Statements .. +* +* Choose padding value, and make it unique +* + CHECKVAL = DCMPLX( -9.11D0, -9.21D0 ) + IAM = IBTMYPROC() + CHECKVAL = IAM * CHECKVAL + ISIZE = IBTSIZEOF('I') + ZSIZE = IBTSIZEOF('Z') + ICHECKVAL = -IAM +* +* Verify file parameters +* + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, *) ' ' + WRITE(OUTNUM, 1000 ) + IF( VERB .GT. 0 ) THEN + WRITE(OUTNUM,*) ' ' + WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE + WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE ) + WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT + WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT + WRITE(OUTNUM, 2000) 'NTOP :', NTOP + WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP ) + WRITE(OUTNUM, 2000) 'NMAT :', NMAT + WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT ) + WRITE(OUTNUM, 2000) 'NDEST :', NDEST + WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST ) + WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID + WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID ) + WRITE(OUTNUM, 2000) 'VERB :', VERB + WRITE(OUTNUM,*) ' ' + END IF + IF( VERB .GT. 1 ) THEN + WRITE(OUTNUM,4000) + WRITE(OUTNUM,5000) + END IF + END IF + IF (TOPSREPEAT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSREPEAT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF +* +* Find biggest matrix, so we know where to stick error info +* + I = 0 + DO 10 IMA = 1, NMAT + IPAD = 4 * M0(IMA) + K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD + IF( K .GT. I ) I = K + 10 CONTINUE + I = I + IBTNPROCS() + MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 ) + IF( MAXERR .LT. 1 ) THEN + WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.' + CALL BLACS_ABORT(-1, 1) + END IF + ERRDPTR = I + 1 + ERRIPTR = ERRDPTR + MAXERR + NERR = 0 + TESTNUM = 0 + NFAIL = 0 + NSKIP = 0 +* +* Loop over grids of matrix +* + DO 90 IGR = 1, NGRID +* +* allocate process grid for the next batch of tests +* + CONTEXT = CONTEXT0(IGR) + CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL ) + INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) ) +* + DO 80 ISC = 1, NSCOPE + SCOPE = SCOPE0(ISC) + DO 70 ITO = 1, NTOP + TOP = TOP0(ITO) +* +* If testing multiring ('M') or general tree ('T'), need to +* loop over calls to BLACS_SET to do full test +* + IF( LSAME(TOP, 'M') ) THEN + SETWHAT = 13 + IF( SCOPE .EQ. 'R' ) THEN + ISTART = -(NPCOL - 1) + ISTOP = -ISTART + ELSE IF (SCOPE .EQ. 'C') THEN + ISTART = -(NPROW - 1) + ISTOP = -ISTART + ELSE + ISTART = -(NPROW*NPCOL - 1) + ISTOP = -ISTART + ENDIF + ELSE IF( LSAME(TOP, 'T') ) THEN + SETWHAT = 14 + ISTART = 1 + IF( SCOPE .EQ. 'R' ) THEN + ISTOP = NPCOL - 1 + ELSE IF (SCOPE .EQ. 'C') THEN + ISTOP = NPROW - 1 + ELSE + ISTOP = NPROW*NPCOL - 1 + ENDIF + ELSE + SETWHAT = 0 + ISTART = 1 + ISTOP = 1 + ENDIF + DO 60 IMA = 1, NMAT + M = M0(IMA) + N = N0(IMA) + LDASRC = LDAS0(IMA) + LDADST = LDAD0(IMA) + LDI = LDI0(IMA) + IPRE = 2 * M + IPOST = IPRE + PREAPTR = 1 + APTR = PREAPTR + IPRE +* + DO 50 IDE = 1, NDEST + TESTNUM = TESTNUM + 1 + RDEST2 = RDEST0(IDE) + CDEST2 = CDEST0(IDE) +* +* If everyone gets the answer, create some bogus rdest/cdest +* so IF's are easier +* + ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) ) + IF( ALLRCV ) THEN + RDEST = NPROW - 1 + CDEST = NPCOL - 1 + IF (TOPSCOHRNT.EQ.0) THEN + ITR1 = 0 + ITR2 = 0 + ELSE IF (TOPSCOHRNT.EQ.1) THEN + ITR1 = 1 + ITR2 = 1 + ELSE + ITR1 = 0 + ITR2 = 1 + END IF + ELSE + RDEST = RDEST2 + CDEST = CDEST2 + ITC1 = 0 + ITC2 = 0 + END IF + IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN + NSKIP = NSKIP + 1 + GOTO 50 + END IF +* + IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN + LDA = LDADST + ELSE + LDA = LDASRC + END IF + VALPTR = APTR + IPOST + N * LDA + IF( VERB .GT. 1 ) THEN + IF( IAM .EQ. 0 ) THEN + WRITE(OUTNUM, 6000) + $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N, + $ LDASRC, LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* If I am in scope +* + TESTOK = .TRUE. + IF( INGRID ) THEN + IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR. + $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR. + $ (SCOPE .EQ. 'A') ) THEN +* + K = NERR + DO 40 ITR = ITR1, ITR2 + CALL BLACS_SET(CONTEXT, 15, ITR) + DO 35 ITC = ITC1, ITC2 + CALL BLACS_SET(CONTEXT, 16, ITC) + DO 30 J = ISTART, ISTOP + IF( J.EQ.0) GOTO 30 + IF( SETWHAT.NE.0 ) + $ CALL BLACS_SET(CONTEXT, SETWHAT, J) +* +* +* generate and pad matrix A +* + CALL ZINITMAT('G','-', M, N, MEM(PREAPTR), + $ LDA, IPRE, IPOST, + $ CHECKVAL, TESTNUM, + $ MYROW, MYCOL ) +* +* If they exist, pad RA and CA arrays +* + IF( LDI .NE. -1 ) THEN + DO 15 I = 1, N*LDI + IPRE + IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 15 CONTINUE + RAPTR = 1 + IPRE + CAPTR = 1 + IPRE + ELSE + DO 20 I = 1, IPRE+IPOST + RMEM(I) = ICHECKVAL + CMEM(I) = ICHECKVAL + 20 CONTINUE + RAPTR = 1 + CAPTR = 1 + END IF +* + CALL ZGAMN2D(CONTEXT, SCOPE, TOP, M, N, + $ MEM(APTR), LDA, RMEM(RAPTR), + $ CMEM(CAPTR), LDI, + $ RDEST2, CDEST2) +* +* If I've got the answer, check for errors in +* matrix or padding +* + IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST) + $ .OR. ALLRCV ) THEN + CALL ZCHKPAD('G','-', M, N, + $ MEM(PREAPTR), LDA, RDEST, + $ CDEST, MYROW, MYCOL, + $ IPRE, IPOST, CHECKVAL, + $ TESTNUM, MAXERR, NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR)) + CALL ZCHKAMN(SCOPE, CONTEXT, M, N, + $ MEM(APTR), LDA, + $ RMEM(RAPTR), CMEM(CAPTR), + $ LDI, TESTNUM, MAXERR,NERR, + $ MEM(ERRIPTR),MEM(ERRDPTR), + $ ISEED, MEM(VALPTR)) + CALL ZRCCHK(IPRE, IPOST, ICHECKVAL, + $ M, N, RMEM, CMEM, LDI, + $ MYROW, MYCOL, TESTNUM, + $ MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR)) + END IF + 30 CONTINUE + CALL BLACS_SET(CONTEXT, 16, 0) + 35 CONTINUE + CALL BLACS_SET(CONTEXT, 15, 0) + 40 CONTINUE + TESTOK = ( K .EQ. NERR ) + END IF + END IF +* + IF( VERB .GT. 1 ) THEN + I = NERR + CALL ZBTCHECKIN(0, OUTNUM, MAXERR, NERR, + $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED) + IF( IAM .EQ. 0 ) THEN + IF( TESTOK .AND. NERR.EQ.I ) THEN + WRITE(OUTNUM,6000)TESTNUM,'PASSED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + ELSE + NFAIL = NFAIL + 1 + WRITE(OUTNUM,6000)TESTNUM,'FAILED ', + $ SCOPE, TOP, M, N, LDASRC, + $ LDADST, LDI, RDEST2, CDEST2, + $ NPROW, NPCOL + END IF + END IF +* +* Once we've printed out errors, can re-use buf space +* + NERR = 0 + END IF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* + IF( VERB .LT. 2 ) THEN + NFAIL = TESTNUM + CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR), + $ MEM(ERRDPTR), ISEED ) + END IF + IF( IAM .EQ. 0 ) THEN + IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' ' + IF( NFAIL+NSKIP .EQ. 0 ) THEN + WRITE(OUTNUM, 7000 ) TESTNUM + ELSE + WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL, + $ NSKIP, NFAIL + END IF + END IF +* +* Log whether their were any failures +* + TESTOK = ALLPASS( (NFAIL.EQ.0) ) +* + 1000 FORMAT('DOUBLE COMPLEX AMN TESTS: BEGIN.' ) + 2000 FORMAT(1X,A7,3X,10I6) + 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1, + $ 5X,A1,5X,A1) + 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ', + $ 'RDEST CDEST P Q') + 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ', + $ '----- ----- ---- ----') + 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5) + 7000 FORMAT('DOUBLE COMPLEX AMN TESTS: PASSED ALL', + $ I5, ' TESTS.') + 8000 FORMAT('DOUBLE COMPLEX AMN TESTS:',I5,' TESTS;',I5,' PASSED,', + $ I5,' SKIPPED,',I5,' FAILED.') +* + RETURN +* +* End of ZTESTAMN. +* + END +* + SUBROUTINE ZCHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, + $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, + $ ISEED, VALS ) +* +* .. Scalar Arguments .. + CHARACTER*1 SCOPE + INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR +* .. +* .. Array Arguments .. + INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*) + DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*) +* .. +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM + DOUBLE PRECISION DBTEPS, ZBTABS + DOUBLE COMPLEX ZBTRAN + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, ZBTRAN, DBTEPS, ZBTABS +* .. +* .. External Subroutines .. + EXTERNAL IBTSPCOORD +* .. +* .. Local Scalars .. + LOGICAL ERROR + INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN + INTEGER IAMN, I, J, K, H, DEST, NODE + DOUBLE PRECISION EPS +* .. +* .. Executable Statements .. +* + NPROCS = IBTNPROCS() + EPS = DBTEPS() + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + DEST = MYROW*NPROCS + MYCOL +* +* Set up seeds to match those used by each proc's genmat call +* + IF( SCOPE .EQ. 'R' ) THEN + NNODES = NPCOL + DO 10 I = 0, NNODES-1 + NODE = MYROW * NPROCS + I + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 10 CONTINUE + ELSE IF( SCOPE .EQ. 'C' ) THEN + NNODES = NPROW + DO 20 I = 0, NNODES-1 + NODE = I * NPROCS + MYCOL + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 20 CONTINUE + ELSE + NNODES = NPROW * NPCOL + DO 30 I = 0, NNODES-1 + NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL) + ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 ) + ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 ) + ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 ) + ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 ) + 30 CONTINUE + END IF +* + DO 100 J = 1, N + DO 90 I = 1, M + H = (J-1)*LDI + I + VALS(1) = ZBTRAN( ISEED ) + IAMN = 1 + IF( NNODES .GT. 1 ) THEN + DO 40 K = 1, NNODES-1 + VALS(K+1) = ZBTRAN( ISEED(K*4+1) ) + IF( ZBTABS( VALS(K+1) ) .LT. ZBTABS( VALS(IAMN) ) ) + $ IAMN = K + 1 + 40 CONTINUE + END IF +* +* If BLACS have not returned same value we've chosen +* + IF( A(I,J) .NE. VALS(IAMN) ) THEN +* +* If we have RA and CA arrays +* + IF( LDI .NE. -1 ) THEN +* +* Any number having the same absolute value is a valid max +* + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.GT.0 .AND. K.LE.NNODES ) THEN + ERROR = ABS( ZBTABS(VALS(K)) - ZBTABS(VALS(IAMN)) ) + $ .GT. 3*EPS + IF( .NOT.ERROR ) IAMN = K + ELSE + ERROR = .TRUE. + END IF + ELSE +* +* Error if BLACS answer not same absolute value, or if it +* was not really in the numbers being compared +* + ERROR = ABS( ZBTABS(A(I,J)) - ZBTABS(VALS(IAMN)) ) + $ .GT. 3*EPS + IF( .NOT.ERROR ) THEN + DO 50 K = 1, NNODES + IF( VALS(K) .EQ. A(I,J) ) GOTO 60 + 50 CONTINUE + ERROR = .TRUE. + 60 CONTINUE + ENDIF + END IF +* +* If the value is in error +* + IF( ERROR ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = 5 + ERRDBUF(1, NERR) = A(I,J) + ERRDBUF(2, NERR) = VALS(IAMN) + END IF + END IF +* +* If they are defined, make sure coordinate entries are OK +* + IF( LDI .NE. -1 ) THEN + K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1 + IF( K.NE.IAMN ) THEN +* +* Make sure more than one proc doesn't have exact same value +* (and therefore there may be more than one valid coordinate +* for a single value) +* + IF( K.GT.NNODES .OR. K.LT.1 ) THEN + ERROR = .TRUE. + ELSE + ERROR = ( VALS(K) .NE. VALS(IAMN) ) + END IF + IF( ERROR ) THEN + CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL, + $ NPCOL, RAMN, CAMN ) + IF( RAMN .NE. RA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -5 + ERRDBUF(1, NERR) = RA(H) + ERRDBUF(2, NERR) = RAMN + END IF + IF( CAMN .NE. CA(H) ) THEN + NERR = NERR + 1 + ERRIBUF(1, NERR) = TESTNUM + ERRIBUF(2, NERR) = NNODES + ERRIBUF(3, NERR) = DEST + ERRIBUF(4, NERR) = I + ERRIBUF(5, NERR) = J + ERRIBUF(6, NERR) = -15 + ERRDBUF(1, NERR) = CA(H) + ERRDBUF(2, NERR) = CAMN + END IF + END IF + END IF + END IF + 90 CONTINUE + 100 CONTINUE +* + RETURN +* +* End of ZCHKAMN +* + END +* --- /dev/null +++ blacs-pvm-1.1/TESTING/Cbt.h @@ -0,0 +1,19 @@ +#define ADD_ 0 +#define NOCHANGE 1 +#define UPCASE 2 + +#ifdef UpCase +#define F77_CALL_C UPCASE +#endif + +#ifdef NoChange +#define F77_CALL_C NOCHANGE +#endif + +#ifdef Add_ +#define F77_CALL_C ADD_ +#endif + +#ifndef F77_CALL_C +#define F77_CALL_C ADD_ +#endif --- /dev/null +++ blacs-pvm-1.1/TESTING/tools.f @@ -0,0 +1,2087 @@ +* ================================================================ +* This file contains the following LAPACK routines, for use by the +* BLACS tester: LSAME, SLAMCH, DLAMCH, DLARND, ZLARND, DLARAN, +* and ZLARAN. If you have ScaLAPACK or LAPACK, all of these files +* are present in your library, and you may discard this file and +* point to the appropriate archive instead. +* ================================================================ + + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* Purpose +* ======= +* +* DLAMCH determines double precision machine parameters. +* +* Arguments +* ========= +* +* CMACH (input) CHARACTER*1 +* Specifies the value to be returned by DLAMCH: +* = 'E' or 'e', DLAMCH := eps +* = 'S' or 's , DLAMCH := sfmin +* = 'B' or 'b', DLAMCH := base +* = 'P' or 'p', DLAMCH := eps*base +* = 'N' or 'n', DLAMCH := t +* = 'R' or 'r', DLAMCH := rnd +* = 'M' or 'm', DLAMCH := emin +* = 'U' or 'u', DLAMCH := rmin +* = 'L' or 'l', DLAMCH := emax +* = 'O' or 'o', DLAMCH := rmax +* +* where +* +* eps = relative machine precision +* sfmin = safe minimum, such that 1/sfmin does not overflow +* base = base of the machine +* prec = eps*base +* t = number of (base) digits in the mantissa +* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +* emin = minimum exponent before (gradual) underflow +* rmin = underflow threshold - base**(emin-1) +* emax = largest exponent before overflow +* rmax = overflow threshold - (base**emax)*(1-eps) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL FIRST, LRND + INTEGER BETA, IMAX, IMIN, IT + DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, + $ RND, SFMIN, SMALL, T +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLAMC2 +* .. +* .. Save statement .. + SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, + $ EMAX, RMAX, PREC +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) + BASE = BETA + T = IT + IF( LRND ) THEN + RND = ONE + EPS = ( BASE**( 1-IT ) ) / 2 + ELSE + RND = ZERO + EPS = BASE**( 1-IT ) + END IF + PREC = EPS*BASE + EMIN = IMIN + EMAX = IMAX + SFMIN = RMIN + SMALL = ONE / RMAX + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = BASE + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = PREC + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = T + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = EMIN + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = RMIN + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = EMAX + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = RMAX + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* +* Purpose +* ======= +* +* DLAMC1 determines the machine parameters given by BETA, T, RND, and +* IEEE1. +* +* Arguments +* ========= +* +* BETA (output) INTEGER +* The base of the machine. +* +* T (output) INTEGER +* The number of ( BETA ) digits in the mantissa. +* +* RND (output) LOGICAL +* Specifies whether proper rounding ( RND = .TRUE. ) or +* chopping ( RND = .FALSE. ) occurs in addition. This may not +* be a reliable guide to the way in which the machine performs +* its arithmetic. +* +* IEEE1 (output) LOGICAL +* Specifies whether rounding appears to be done in the IEEE +* 'round to nearest' style. +* +* Further Details +* =============== +* +* The routine is based on the routine ENVRON by Malcolm and +* incorporates suggestions by Gentleman and Marovich. See +* +* Malcolm M. A. (1972) Algorithms to reveal properties of +* floating-point arithmetic. Comms. of the ACM, 15, 949-951. +* +* Gentleman W. M. and Marovich S. B. (1974) More on algorithms +* that reveal properties of floating point arithmetic units. +* Comms. of the ACM, 17, 276-277. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Save statement .. + SAVE FIRST, LIEEE1, LBETA, LRND, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ONE = 1 +* +* LBETA, LIEEE1, LT and LRND are the local values of BETA, +* IEEE1, T and RND. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* Compute a = 2.0**m with the smallest positive integer m such +* that +* +* fl( a + 1.0 ) = a. +* + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 10 CONTINUE + IF( C.EQ.ONE ) THEN + A = 2*A + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 10 + END IF +*+ END WHILE +* +* Now compute b = 2.0**m with the smallest positive integer m +* such that +* +* fl( a + b ) .gt. a. +* + B = 1 + C = DLAMC3( A, B ) +* +*+ WHILE( C.EQ.A )LOOP + 20 CONTINUE + IF( C.EQ.A ) THEN + B = 2*B + C = DLAMC3( A, B ) + GO TO 20 + END IF +*+ END WHILE +* +* Now compute the base. a and c are neighbouring floating point +* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so +* their difference is beta. Adding 0.25 to c is to ensure that it +* is truncated to beta and not ( beta - 1 ). +* + QTR = ONE / 4 + SAVEC = C + C = DLAMC3( C, -A ) + LBETA = C + QTR +* +* Now determine whether rounding or chopping occurs, by adding a +* bit less than beta/2 and a bit more than beta/2 to a. +* + B = LBETA + F = DLAMC3( B / 2, -B / 100 ) + C = DLAMC3( F, A ) + IF( C.EQ.A ) THEN + LRND = .TRUE. + ELSE + LRND = .FALSE. + END IF + F = DLAMC3( B / 2, B / 100 ) + C = DLAMC3( F, A ) + IF( ( LRND ) .AND. ( C.EQ.A ) ) + $ LRND = .FALSE. +* +* Try and decide whether rounding is done in the IEEE 'round to +* nearest' style. B/2 is half a unit in the last place of the two +* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit +* zero, and SAVEC is odd. Thus adding B/2 to A should not change +* A, but adding B/2 to SAVEC should change SAVEC. +* + T1 = DLAMC3( B / 2, A ) + T2 = DLAMC3( B / 2, SAVEC ) + LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND +* +* Now find the mantissa, t. It should be the integer part of +* log to the base beta of a, however it is safer to determine t +* by powering. So we find t as the smallest positive integer for +* which +* +* fl( beta**t + 1.0 ) = 1.0. +* + LT = 0 + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 30 CONTINUE + IF( C.EQ.ONE ) THEN + LT = LT + 1 + A = A*LBETA + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + BETA = LBETA + T = LT + RND = LRND + IEEE1 = LIEEE1 + RETURN +* +* End of DLAMC1 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + DOUBLE PRECISION EPS, RMAX, RMIN +* .. +* +* Purpose +* ======= +* +* DLAMC2 determines the machine parameters specified in its argument +* list. +* +* Arguments +* ========= +* +* BETA (output) INTEGER +* The base of the machine. +* +* T (output) INTEGER +* The number of ( BETA ) digits in the mantissa. +* +* RND (output) LOGICAL +* Specifies whether proper rounding ( RND = .TRUE. ) or +* chopping ( RND = .FALSE. ) occurs in addition. This may not +* be a reliable guide to the way in which the machine performs +* its arithmetic. +* +* EPS (output) DOUBLE PRECISION +* The smallest positive number such that +* +* fl( 1.0 - EPS ) .LT. 1.0, +* +* where fl denotes the computed value. +* +* EMIN (output) INTEGER +* The minimum exponent before (gradual) underflow occurs. +* +* RMIN (output) DOUBLE PRECISION +* The smallest normalized number for the machine, given by +* BASE**( EMIN - 1 ), where BASE is the floating point value +* of BETA. +* +* EMAX (output) INTEGER +* The maximum exponent before overflow occurs. +* +* RMAX (output) DOUBLE PRECISION +* The largest positive number for the machine, given by +* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point +* value of BETA. +* +* Further Details +* =============== +* +* The computation of EPS is based on a routine PARANOIA by +* W. Kahan of the University of California at Berkeley. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ NGNMIN, NGPMIN + DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ SIXTH, SMALL, THIRD, TWO, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. External Subroutines .. + EXTERNAL DLAMC1, DLAMC4, DLAMC5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Save statement .. + SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, + $ LRMIN, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / , IWARN / .FALSE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ZERO = 0 + ONE = 1 + TWO = 2 +* +* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of +* BETA, T, RND, EPS, EMIN and RMIN. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. +* + CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) +* +* Start to find EPS. +* + B = LBETA + A = B**( -LT ) + LEPS = A +* +* Try some tricks to see whether or not this is the correct EPS. +* + B = TWO / 3 + HALF = ONE / 2 + SIXTH = DLAMC3( B, -HALF ) + THIRD = DLAMC3( SIXTH, SIXTH ) + B = DLAMC3( THIRD, -HALF ) + B = DLAMC3( B, SIXTH ) + B = ABS( B ) + IF( B.LT.LEPS ) + $ B = LEPS +* + LEPS = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN + LEPS = B + C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) + C = DLAMC3( HALF, -C ) + B = DLAMC3( HALF, C ) + C = DLAMC3( HALF, -B ) + B = DLAMC3( HALF, C ) + GO TO 10 + END IF +*+ END WHILE +* + IF( A.LT.LEPS ) + $ LEPS = A +* +* Computation of EPS complete. +* +* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). +* Keep dividing A by BETA until (gradual) underflow occurs. This +* is detected when we cannot recover the previous A. +* + RBASE = ONE / LBETA + SMALL = ONE + DO 20 I = 1, 3 + SMALL = DLAMC3( SMALL*RBASE, ZERO ) + 20 CONTINUE + A = DLAMC3( ONE, SMALL ) + CALL DLAMC4( NGPMIN, ONE, LBETA ) + CALL DLAMC4( NGNMIN, -ONE, LBETA ) + CALL DLAMC4( GPMIN, A, LBETA ) + CALL DLAMC4( GNMIN, -A, LBETA ) + IEEE = .FALSE. +* + IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN + IF( NGPMIN.EQ.GPMIN ) THEN + LEMIN = NGPMIN +* ( Non twos-complement machines, no gradual underflow; +* e.g., VAX ) + ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN + LEMIN = NGPMIN - 1 + LT + IEEE = .TRUE. +* ( Non twos-complement machines, with gradual underflow; +* e.g., IEEE standard followers ) + ELSE + LEMIN = MIN( NGPMIN, GPMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN + IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) +* ( Twos-complement machines, no gradual underflow; +* e.g., CYBER 205 ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. + $ ( GPMIN.EQ.GNMIN ) ) THEN + IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT +* ( Twos-complement machines with gradual underflow; +* no known machine ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE + LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +*** +* Comment out this if block if EMIN is ok + IF( IWARN ) THEN + FIRST = .TRUE. + WRITE( 6, FMT = 9999 )LEMIN + END IF +*** +* +* Assume IEEE arithmetic if we found denormalised numbers above, +* or if arithmetic seems to round in the IEEE style, determined +* in routine DLAMC1. A true IEEE machine should have both things +* true; however, faulty machines may have one or the other. +* + IEEE = IEEE .OR. LIEEE1 +* +* Compute RMIN by successive division by BETA. We could compute +* RMIN as BASE**( EMIN - 1 ), but some machines underflow during +* this computation. +* + LRMIN = 1 + DO 30 I = 1, 1 - LEMIN + LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) + 30 CONTINUE +* +* Finally, call DLAMC5 to compute EMAX and RMAX. +* + CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) + END IF +* + BETA = LBETA + T = LT + RND = LRND + EPS = LEPS + EMIN = LEMIN + RMIN = LRMIN + EMAX = LEMAX + RMAX = LRMAX +* + RETURN +* + 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', + $ ' EMIN = ', I8, / + $ ' If, after inspection, the value EMIN looks', + $ ' acceptable please comment out ', + $ / ' the IF block as marked within the code of routine', + $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) +* +* End of DLAMC2 +* + END +* +************************************************************************ +* + DOUBLE PRECISION FUNCTION DLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* +* Purpose +* ======= +* +* DLAMC3 is intended to force A and B to be stored prior to doing +* the addition of A and B , for use in situations where optimizers +* might hold one of these in a register. +* +* Arguments +* ========= +* +* A, B (input) DOUBLE PRECISION +* The values A and B. +* +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC4( EMIN, START, BASE ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + INTEGER BASE, EMIN + DOUBLE PRECISION START +* .. +* +* Purpose +* ======= +* +* DLAMC4 is a service routine for DLAMC2. +* +* Arguments +* ========= +* +* EMIN (output) EMIN +* The minimum exponent before (gradual) underflow, computed by +* setting A = START and dividing by BASE until the previous A +* can not be recovered. +* +* START (input) DOUBLE PRECISION +* The starting point for determining EMIN. +* +* BASE (input) INTEGER +* The base of the machine. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Executable Statements .. +* + A = START + ONE = 1 + RBASE = ONE / BASE + ZERO = 0 + EMIN = 1 + B1 = DLAMC3( A*RBASE, ZERO ) + C1 = A + C2 = A + D1 = A + D2 = A +*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. +* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP + 10 CONTINUE + IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. + $ ( D2.EQ.A ) ) THEN + EMIN = EMIN - 1 + A = B1 + B1 = DLAMC3( A / BASE, ZERO ) + C1 = DLAMC3( B1*BASE, ZERO ) + D1 = ZERO + DO 20 I = 1, BASE + D1 = D1 + B1 + 20 CONTINUE + B2 = DLAMC3( A*RBASE, ZERO ) + C2 = DLAMC3( B2 / RBASE, ZERO ) + D2 = ZERO + DO 30 I = 1, BASE + D2 = D2 + B2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* End of DLAMC4 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + DOUBLE PRECISION RMAX +* .. +* +* Purpose +* ======= +* +* DLAMC5 attempts to compute RMAX, the largest machine floating-point +* number, without overflow. It assumes that EMAX + abs(EMIN) sum +* approximately to a power of 2. It will fail on machines where this +* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, +* EMAX = 28718). It will also fail if the value supplied for EMIN is +* too large (i.e. too close to zero), probably with overflow. +* +* Arguments +* ========= +* +* BETA (input) INTEGER +* The base of floating-point arithmetic. +* +* P (input) INTEGER +* The number of base BETA digits in the mantissa of a +* floating-point value. +* +* EMIN (input) INTEGER +* The minimum exponent before (gradual) underflow. +* +* IEEE (input) LOGICAL +* A logical flag specifying whether or not the arithmetic +* system is thought to comply with the IEEE standard. +* +* EMAX (output) INTEGER +* The largest exponent before overflow +* +* RMAX (output) DOUBLE PRECISION +* The largest machine floating-point number. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + DOUBLE PRECISION OLDY, RECBAS, Y, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* First compute LEXP and UEXP, two powers of 2 that bound +* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum +* approximately to the bound that is closest to abs(EMIN). +* (EMAX is the exponent of the required number RMAX). +* + LEXP = 1 + EXBITS = 1 + 10 CONTINUE + TRY = LEXP*2 + IF( TRY.LE.( -EMIN ) ) THEN + LEXP = TRY + EXBITS = EXBITS + 1 + GO TO 10 + END IF + IF( LEXP.EQ.-EMIN ) THEN + UEXP = LEXP + ELSE + UEXP = TRY + EXBITS = EXBITS + 1 + END IF +* +* Now -LEXP is less than or equal to EMIN, and -UEXP is greater +* than or equal to EMIN. EXBITS is the number of bits needed to +* store the exponent. +* + IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN + EXPSUM = 2*LEXP + ELSE + EXPSUM = 2*UEXP + END IF +* +* EXPSUM is the exponent range, approximately equal to +* EMAX - EMIN + 1 . +* + EMAX = EXPSUM + EMIN - 1 + NBITS = 1 + EXBITS + P +* +* NBITS is the total number of bits needed to store a +* floating-point number. +* + IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN +* +* Either there are an odd number of bits used to store a +* floating-point number, which is unlikely, or some bits are +* not used in the representation of numbers, which is possible, +* (e.g. Cray machines) or the mantissa has an implicit bit, +* (e.g. IEEE machines, Dec Vax machines), which is perhaps the +* most likely. We have to assume the last alternative. +* If this is true, then we need to reduce EMAX by one because +* there must be some way of representing zero in an implicit-bit +* system. On machines like Cray, we are reducing EMAX by one +* unnecessarily. +* + EMAX = EMAX - 1 + END IF +* + IF( IEEE ) THEN +* +* Assume we are on an IEEE machine which reserves one exponent +* for infinity and NaN. +* + EMAX = EMAX - 1 + END IF +* +* Now create RMAX, the largest machine number, which should +* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . +* +* First compute 1.0 - BETA**(-P), being careful that the +* result is less than 1.0 . +* + RECBAS = ONE / BETA + Z = BETA - ONE + Y = ZERO + DO 20 I = 1, P + Z = Z*RECBAS + IF( Y.LT.ONE ) + $ OLDY = Y + Y = DLAMC3( Y, Z ) + 20 CONTINUE + IF( Y.GE.ONE ) + $ Y = OLDY +* +* Now multiply by BETA**EMAX to get RMAX. +* + DO 30 I = 1, EMAX + Y = DLAMC3( Y*BETA, ZERO ) + 30 CONTINUE +* + RMAX = Y + RETURN +* +* End of DLAMC5 +* + END + REAL FUNCTION SLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* Purpose +* ======= +* +* SLAMCH determines single precision machine parameters. +* +* Arguments +* ========= +* +* CMACH (input) CHARACTER*1 +* Specifies the value to be returned by SLAMCH: +* = 'E' or 'e', SLAMCH := eps +* = 'S' or 's , SLAMCH := sfmin +* = 'B' or 'b', SLAMCH := base +* = 'P' or 'p', SLAMCH := eps*base +* = 'N' or 'n', SLAMCH := t +* = 'R' or 'r', SLAMCH := rnd +* = 'M' or 'm', SLAMCH := emin +* = 'U' or 'u', SLAMCH := rmin +* = 'L' or 'l', SLAMCH := emax +* = 'O' or 'o', SLAMCH := rmax +* +* where +* +* eps = relative machine precision +* sfmin = safe minimum, such that 1/sfmin does not overflow +* base = base of the machine +* prec = eps*base +* t = number of (base) digits in the mantissa +* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +* emin = minimum exponent before (gradual) underflow +* rmin = underflow threshold - base**(emin-1) +* emax = largest exponent before overflow +* rmax = overflow threshold - (base**emax)*(1-eps) +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL FIRST, LRND + INTEGER BETA, IMAX, IMIN, IT + REAL BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, + $ RND, SFMIN, SMALL, T +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SLAMC2 +* .. +* .. Save statement .. + SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, + $ EMAX, RMAX, PREC +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) + BASE = BETA + T = IT + IF( LRND ) THEN + RND = ONE + EPS = ( BASE**( 1-IT ) ) / 2 + ELSE + RND = ZERO + EPS = BASE**( 1-IT ) + END IF + PREC = EPS*BASE + EMIN = IMIN + EMAX = IMAX + SFMIN = RMIN + SMALL = ONE / RMAX + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = BASE + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = PREC + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = T + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = EMIN + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = RMIN + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = EMAX + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = RMAX + END IF +* + SLAMCH = RMACH + RETURN +* +* End of SLAMCH +* + END +* +************************************************************************ +* + SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* +* Purpose +* ======= +* +* SLAMC1 determines the machine parameters given by BETA, T, RND, and +* IEEE1. +* +* Arguments +* ========= +* +* BETA (output) INTEGER +* The base of the machine. +* +* T (output) INTEGER +* The number of ( BETA ) digits in the mantissa. +* +* RND (output) LOGICAL +* Specifies whether proper rounding ( RND = .TRUE. ) or +* chopping ( RND = .FALSE. ) occurs in addition. This may not +* be a reliable guide to the way in which the machine performs +* its arithmetic. +* +* IEEE1 (output) LOGICAL +* Specifies whether rounding appears to be done in the IEEE +* 'round to nearest' style. +* +* Further Details +* =============== +* +* The routine is based on the routine ENVRON by Malcolm and +* incorporates suggestions by Gentleman and Marovich. See +* +* Malcolm M. A. (1972) Algorithms to reveal properties of +* floating-point arithmetic. Comms. of the ACM, 15, 949-951. +* +* Gentleman W. M. and Marovich S. B. (1974) More on algorithms +* that reveal properties of floating point arithmetic units. +* Comms. of the ACM, 17, 276-277. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + REAL A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. External Functions .. + REAL SLAMC3 + EXTERNAL SLAMC3 +* .. +* .. Save statement .. + SAVE FIRST, LIEEE1, LBETA, LRND, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ONE = 1 +* +* LBETA, LIEEE1, LT and LRND are the local values of BETA, +* IEEE1, T and RND. +* +* Throughout this routine we use the function SLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* Compute a = 2.0**m with the smallest positive integer m such +* that +* +* fl( a + 1.0 ) = a. +* + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 10 CONTINUE + IF( C.EQ.ONE ) THEN + A = 2*A + C = SLAMC3( A, ONE ) + C = SLAMC3( C, -A ) + GO TO 10 + END IF +*+ END WHILE +* +* Now compute b = 2.0**m with the smallest positive integer m +* such that +* +* fl( a + b ) .gt. a. +* + B = 1 + C = SLAMC3( A, B ) +* +*+ WHILE( C.EQ.A )LOOP + 20 CONTINUE + IF( C.EQ.A ) THEN + B = 2*B + C = SLAMC3( A, B ) + GO TO 20 + END IF +*+ END WHILE +* +* Now compute the base. a and c are neighbouring floating point +* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so +* their difference is beta. Adding 0.25 to c is to ensure that it +* is truncated to beta and not ( beta - 1 ). +* + QTR = ONE / 4 + SAVEC = C + C = SLAMC3( C, -A ) + LBETA = C + QTR +* +* Now determine whether rounding or chopping occurs, by adding a +* bit less than beta/2 and a bit more than beta/2 to a. +* + B = LBETA + F = SLAMC3( B / 2, -B / 100 ) + C = SLAMC3( F, A ) + IF( C.EQ.A ) THEN + LRND = .TRUE. + ELSE + LRND = .FALSE. + END IF + F = SLAMC3( B / 2, B / 100 ) + C = SLAMC3( F, A ) + IF( ( LRND ) .AND. ( C.EQ.A ) ) + $ LRND = .FALSE. +* +* Try and decide whether rounding is done in the IEEE 'round to +* nearest' style. B/2 is half a unit in the last place of the two +* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit +* zero, and SAVEC is odd. Thus adding B/2 to A should not change +* A, but adding B/2 to SAVEC should change SAVEC. +* + T1 = SLAMC3( B / 2, A ) + T2 = SLAMC3( B / 2, SAVEC ) + LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND +* +* Now find the mantissa, t. It should be the integer part of +* log to the base beta of a, however it is safer to determine t +* by powering. So we find t as the smallest positive integer for +* which +* +* fl( beta**t + 1.0 ) = 1.0. +* + LT = 0 + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 30 CONTINUE + IF( C.EQ.ONE ) THEN + LT = LT + 1 + A = A*LBETA + C = SLAMC3( A, ONE ) + C = SLAMC3( C, -A ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + BETA = LBETA + T = LT + RND = LRND + IEEE1 = LIEEE1 + RETURN +* +* End of SLAMC1 +* + END +* +************************************************************************ +* + SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + REAL EPS, RMAX, RMIN +* .. +* +* Purpose +* ======= +* +* SLAMC2 determines the machine parameters specified in its argument +* list. +* +* Arguments +* ========= +* +* BETA (output) INTEGER +* The base of the machine. +* +* T (output) INTEGER +* The number of ( BETA ) digits in the mantissa. +* +* RND (output) LOGICAL +* Specifies whether proper rounding ( RND = .TRUE. ) or +* chopping ( RND = .FALSE. ) occurs in addition. This may not +* be a reliable guide to the way in which the machine performs +* its arithmetic. +* +* EPS (output) REAL +* The smallest positive number such that +* +* fl( 1.0 - EPS ) .LT. 1.0, +* +* where fl denotes the computed value. +* +* EMIN (output) INTEGER +* The minimum exponent before (gradual) underflow occurs. +* +* RMIN (output) REAL +* The smallest normalized number for the machine, given by +* BASE**( EMIN - 1 ), where BASE is the floating point value +* of BETA. +* +* EMAX (output) INTEGER +* The maximum exponent before overflow occurs. +* +* RMAX (output) REAL +* The largest positive number for the machine, given by +* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point +* value of BETA. +* +* Further Details +* =============== +* +* The computation of EPS is based on a routine PARANOIA by +* W. Kahan of the University of California at Berkeley. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ NGNMIN, NGPMIN + REAL A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ SIXTH, SMALL, THIRD, TWO, ZERO +* .. +* .. External Functions .. + REAL SLAMC3 + EXTERNAL SLAMC3 +* .. +* .. External Subroutines .. + EXTERNAL SLAMC1, SLAMC4, SLAMC5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Save statement .. + SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, + $ LRMIN, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / , IWARN / .FALSE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ZERO = 0 + ONE = 1 + TWO = 2 +* +* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of +* BETA, T, RND, EPS, EMIN and RMIN. +* +* Throughout this routine we use the function SLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. +* + CALL SLAMC1( LBETA, LT, LRND, LIEEE1 ) +* +* Start to find EPS. +* + B = LBETA + A = B**( -LT ) + LEPS = A +* +* Try some tricks to see whether or not this is the correct EPS. +* + B = TWO / 3 + HALF = ONE / 2 + SIXTH = SLAMC3( B, -HALF ) + THIRD = SLAMC3( SIXTH, SIXTH ) + B = SLAMC3( THIRD, -HALF ) + B = SLAMC3( B, SIXTH ) + B = ABS( B ) + IF( B.LT.LEPS ) + $ B = LEPS +* + LEPS = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN + LEPS = B + C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) + C = SLAMC3( HALF, -C ) + B = SLAMC3( HALF, C ) + C = SLAMC3( HALF, -B ) + B = SLAMC3( HALF, C ) + GO TO 10 + END IF +*+ END WHILE +* + IF( A.LT.LEPS ) + $ LEPS = A +* +* Computation of EPS complete. +* +* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). +* Keep dividing A by BETA until (gradual) underflow occurs. This +* is detected when we cannot recover the previous A. +* + RBASE = ONE / LBETA + SMALL = ONE + DO 20 I = 1, 3 + SMALL = SLAMC3( SMALL*RBASE, ZERO ) + 20 CONTINUE + A = SLAMC3( ONE, SMALL ) + CALL SLAMC4( NGPMIN, ONE, LBETA ) + CALL SLAMC4( NGNMIN, -ONE, LBETA ) + CALL SLAMC4( GPMIN, A, LBETA ) + CALL SLAMC4( GNMIN, -A, LBETA ) + IEEE = .FALSE. +* + IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN + IF( NGPMIN.EQ.GPMIN ) THEN + LEMIN = NGPMIN +* ( Non twos-complement machines, no gradual underflow; +* e.g., VAX ) + ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN + LEMIN = NGPMIN - 1 + LT + IEEE = .TRUE. +* ( Non twos-complement machines, with gradual underflow; +* e.g., IEEE standard followers ) + ELSE + LEMIN = MIN( NGPMIN, GPMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN + IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) +* ( Twos-complement machines, no gradual underflow; +* e.g., CYBER 205 ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. + $ ( GPMIN.EQ.GNMIN ) ) THEN + IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT +* ( Twos-complement machines with gradual underflow; +* no known machine ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE + LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +*** +* Comment out this if block if EMIN is ok + IF( IWARN ) THEN + FIRST = .TRUE. + WRITE( 6, FMT = 9999 )LEMIN + END IF +*** +* +* Assume IEEE arithmetic if we found denormalised numbers above, +* or if arithmetic seems to round in the IEEE style, determined +* in routine SLAMC1. A true IEEE machine should have both things +* true; however, faulty machines may have one or the other. +* + IEEE = IEEE .OR. LIEEE1 +* +* Compute RMIN by successive division by BETA. We could compute +* RMIN as BASE**( EMIN - 1 ), but some machines underflow during +* this computation. +* + LRMIN = 1 + DO 30 I = 1, 1 - LEMIN + LRMIN = SLAMC3( LRMIN*RBASE, ZERO ) + 30 CONTINUE +* +* Finally, call SLAMC5 to compute EMAX and RMAX. +* + CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) + END IF +* + BETA = LBETA + T = LT + RND = LRND + EPS = LEPS + EMIN = LEMIN + RMIN = LRMIN + EMAX = LEMAX + RMAX = LRMAX +* + RETURN +* + 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', + $ ' EMIN = ', I8, / + $ ' If, after inspection, the value EMIN looks', + $ ' acceptable please comment out ', + $ / ' the IF block as marked within the code of routine', + $ ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / ) +* +* End of SLAMC2 +* + END +* +************************************************************************ +* + REAL FUNCTION SLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + REAL A, B +* .. +* +* Purpose +* ======= +* +* SLAMC3 is intended to force A and B to be stored prior to doing +* the addition of A and B , for use in situations where optimizers +* might hold one of these in a register. +* +* Arguments +* ========= +* +* A, B (input) REAL +* The values A and B. +* +* ===================================================================== +* +* .. Executable Statements .. +* + SLAMC3 = A + B +* + RETURN +* +* End of SLAMC3 +* + END +* +************************************************************************ +* + SUBROUTINE SLAMC4( EMIN, START, BASE ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + INTEGER BASE, EMIN + REAL START +* .. +* +* Purpose +* ======= +* +* SLAMC4 is a service routine for SLAMC2. +* +* Arguments +* ========= +* +* EMIN (output) EMIN +* The minimum exponent before (gradual) underflow, computed by +* setting A = START and dividing by BASE until the previous A +* can not be recovered. +* +* START (input) REAL +* The starting point for determining EMIN. +* +* BASE (input) INTEGER +* The base of the machine. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I + REAL A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. External Functions .. + REAL SLAMC3 + EXTERNAL SLAMC3 +* .. +* .. Executable Statements .. +* + A = START + ONE = 1 + RBASE = ONE / BASE + ZERO = 0 + EMIN = 1 + B1 = SLAMC3( A*RBASE, ZERO ) + C1 = A + C2 = A + D1 = A + D2 = A +*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. +* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP + 10 CONTINUE + IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. + $ ( D2.EQ.A ) ) THEN + EMIN = EMIN - 1 + A = B1 + B1 = SLAMC3( A / BASE, ZERO ) + C1 = SLAMC3( B1*BASE, ZERO ) + D1 = ZERO + DO 20 I = 1, BASE + D1 = D1 + B1 + 20 CONTINUE + B2 = SLAMC3( A*RBASE, ZERO ) + C2 = SLAMC3( B2 / RBASE, ZERO ) + D2 = ZERO + DO 30 I = 1, BASE + D2 = D2 + B2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* End of SLAMC4 +* + END +* +************************************************************************ +* + SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + REAL RMAX +* .. +* +* Purpose +* ======= +* +* SLAMC5 attempts to compute RMAX, the largest machine floating-point +* number, without overflow. It assumes that EMAX + abs(EMIN) sum +* approximately to a power of 2. It will fail on machines where this +* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, +* EMAX = 28718). It will also fail if the value supplied for EMIN is +* too large (i.e. too close to zero), probably with overflow. +* +* Arguments +* ========= +* +* BETA (input) INTEGER +* The base of floating-point arithmetic. +* +* P (input) INTEGER +* The number of base BETA digits in the mantissa of a +* floating-point value. +* +* EMIN (input) INTEGER +* The minimum exponent before (gradual) underflow. +* +* IEEE (input) LOGICAL +* A logical flag specifying whether or not the arithmetic +* system is thought to comply with the IEEE standard. +* +* EMAX (output) INTEGER +* The largest exponent before overflow +* +* RMAX (output) REAL +* The largest machine floating-point number. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + REAL OLDY, RECBAS, Y, Z +* .. +* .. External Functions .. + REAL SLAMC3 + EXTERNAL SLAMC3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* First compute LEXP and UEXP, two powers of 2 that bound +* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum +* approximately to the bound that is closest to abs(EMIN). +* (EMAX is the exponent of the required number RMAX). +* + LEXP = 1 + EXBITS = 1 + 10 CONTINUE + TRY = LEXP*2 + IF( TRY.LE.( -EMIN ) ) THEN + LEXP = TRY + EXBITS = EXBITS + 1 + GO TO 10 + END IF + IF( LEXP.EQ.-EMIN ) THEN + UEXP = LEXP + ELSE + UEXP = TRY + EXBITS = EXBITS + 1 + END IF +* +* Now -LEXP is less than or equal to EMIN, and -UEXP is greater +* than or equal to EMIN. EXBITS is the number of bits needed to +* store the exponent. +* + IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN + EXPSUM = 2*LEXP + ELSE + EXPSUM = 2*UEXP + END IF +* +* EXPSUM is the exponent range, approximately equal to +* EMAX - EMIN + 1 . +* + EMAX = EXPSUM + EMIN - 1 + NBITS = 1 + EXBITS + P +* +* NBITS is the total number of bits needed to store a +* floating-point number. +* + IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN +* +* Either there are an odd number of bits used to store a +* floating-point number, which is unlikely, or some bits are +* not used in the representation of numbers, which is possible, +* (e.g. Cray machines) or the mantissa has an implicit bit, +* (e.g. IEEE machines, Dec Vax machines), which is perhaps the +* most likely. We have to assume the last alternative. +* If this is true, then we need to reduce EMAX by one because +* there must be some way of representing zero in an implicit-bit +* system. On machines like Cray, we are reducing EMAX by one +* unnecessarily. +* + EMAX = EMAX - 1 + END IF +* + IF( IEEE ) THEN +* +* Assume we are on an IEEE machine which reserves one exponent +* for infinity and NaN. +* + EMAX = EMAX - 1 + END IF +* +* Now create RMAX, the largest machine number, which should +* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . +* +* First compute 1.0 - BETA**(-P), being careful that the +* result is less than 1.0 . +* + RECBAS = ONE / BETA + Z = BETA - ONE + Y = ZERO + DO 20 I = 1, P + Z = Z*RECBAS + IF( Y.LT.ONE ) + $ OLDY = Y + Y = SLAMC3( Y, Z ) + 20 CONTINUE + IF( Y.GE.ONE ) + $ Y = OLDY +* +* Now multiply by BETA**EMAX to get RMAX. +* + DO 30 I = 1, EMAX + Y = SLAMC3( Y*BETA, ZERO ) + 30 CONTINUE +* + RMAX = Y + RETURN +* +* End of SLAMC5 +* + END + LOGICAL FUNCTION LSAME( CA, CB ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1994 +* +* .. Scalar Arguments .. + CHARACTER CA, CB +* .. +* +* Purpose +* ======= +* +* LSAME returns .TRUE. if CA is the same letter as CB regardless of +* case. +* +* Arguments +* ========= +* +* CA (input) CHARACTER*1 +* CB (input) CHARACTER*1 +* CA and CB specify the single characters to be compared. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA, INTB, ZCODE +* .. +* .. Executable Statements .. +* +* Test if the characters are equal +* + LSAME = CA.EQ.CB + IF( LSAME ) + $ RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR( 'Z' ) +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR( CA ) + INTB = ICHAR( CB ) +* + IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 + IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 +* + ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.129 .AND. INTA.LE.137 .OR. + $ INTA.GE.145 .AND. INTA.LE.153 .OR. + $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 + IF( INTB.GE.129 .AND. INTB.LE.137 .OR. + $ INTB.GE.145 .AND. INTB.LE.153 .OR. + $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 +* + ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 + IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 + END IF + LSAME = INTA.EQ.INTB +* +* RETURN +* +* End of LSAME +* + END + DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1994 +* +* .. Scalar Arguments .. + INTEGER IDIST +* .. +* .. Array Arguments .. + INTEGER ISEED( 4 ) +* .. +* +* Purpose +* ======= +* +* DLARND returns a random real number from a uniform or normal +* distribution. +* +* Arguments +* ========= +* +* IDIST (input) INTEGER +* Specifies the distribution of the random numbers: +* = 1: uniform (0,1) +* = 2: uniform (-1,1) +* = 3: normal (0,1) +* +* ISEED (input/output) INTEGER array, dimension (4) +* On entry, the seed of the random number generator; the array +* elements must be between 0 and 4095, and ISEED(4) must be +* odd. +* On exit, the seed is updated. +* +* Further Details +* =============== +* +* This routine calls the auxiliary routine DLARAN to generate a random +* real number from a uniform (0,1) distribution. The Box-Muller method +* is used to transform numbers from a uniform to a normal distribution. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) + DOUBLE PRECISION TWOPI + PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLARAN + EXTERNAL DLARAN +* .. +* .. Intrinsic Functions .. + INTRINSIC COS, LOG, SQRT +* .. +* .. Executable Statements .. +* +* Generate a real random number from a uniform (0,1) distribution +* + T1 = DLARAN( ISEED ) +* + IF( IDIST.EQ.1 ) THEN +* +* uniform (0,1) +* + DLARND = T1 + ELSE IF( IDIST.EQ.2 ) THEN +* +* uniform (-1,1) +* + DLARND = TWO*T1 - ONE + ELSE IF( IDIST.EQ.3 ) THEN +* +* normal (0,1) +* + T2 = DLARAN( ISEED ) + DLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 ) + END IF + RETURN +* +* End of DLARND +* + END + DOUBLE COMPLEX FUNCTION ZLARND( IDIST, ISEED ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1994 +* +* .. Scalar Arguments .. + INTEGER IDIST +* .. +* .. Array Arguments .. + INTEGER ISEED( 4 ) +* .. +* +* Purpose +* ======= +* +* ZLARND returns a random complex number from a uniform or normal +* distribution. +* +* Arguments +* ========= +* +* IDIST (input) INTEGER +* Specifies the distribution of the random numbers: +* = 1: real and imaginary parts each uniform (0,1) +* = 2: real and imaginary parts each uniform (-1,1) +* = 3: real and imaginary parts each normal (0,1) +* = 4: uniformly distributed on the disc abs(z) <= 1 +* = 5: uniformly distributed on the circle abs(z) = 1 +* +* ISEED (input/output) INTEGER array, dimension (4) +* On entry, the seed of the random number generator; the array +* elements must be between 0 and 4095, and ISEED(4) must be +* odd. +* On exit, the seed is updated. +* +* Further Details +* =============== +* +* This routine calls the auxiliary routine DLARAN to generate a random +* real number from a uniform (0,1) distribution. The Box-Muller method +* is used to transform numbers from a uniform to a normal distribution. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + DOUBLE PRECISION TWOPI + PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLARAN + EXTERNAL DLARAN +* .. +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, EXP, LOG, SQRT +* .. +* .. Executable Statements .. +* +* Generate a pair of real random numbers from a uniform (0,1) +* distribution +* + T1 = DLARAN( ISEED ) + T2 = DLARAN( ISEED ) +* + IF( IDIST.EQ.1 ) THEN +* +* real and imaginary parts each uniform (0,1) +* + ZLARND = DCMPLX( T1, T2 ) + ELSE IF( IDIST.EQ.2 ) THEN +* +* real and imaginary parts each uniform (-1,1) +* + ZLARND = DCMPLX( TWO*T1-ONE, TWO*T2-ONE ) + ELSE IF( IDIST.EQ.3 ) THEN +* +* real and imaginary parts each normal (0,1) +* + ZLARND = SQRT( -TWO*LOG( T1 ) )*EXP( DCMPLX( ZERO, TWOPI*T2 ) ) + ELSE IF( IDIST.EQ.4 ) THEN +* +* uniform distribution on the unit disc abs(z) <= 1 +* + ZLARND = SQRT( T1 )*EXP( DCMPLX( ZERO, TWOPI*T2 ) ) + ELSE IF( IDIST.EQ.5 ) THEN +* +* uniform distribution on the unit circle abs(z) = 1 +* + ZLARND = EXP( DCMPLX( ZERO, TWOPI*T2 ) ) + END IF + RETURN +* +* End of ZLARND +* + END + DOUBLE PRECISION FUNCTION DLARAN( ISEED ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Array Arguments .. + INTEGER ISEED( 4 ) +* .. +* +* Purpose +* ======= +* +* DLARAN returns a random real number from a uniform (0,1) +* distribution. +* +* Arguments +* ========= +* +* ISEED (input/output) INTEGER array, dimension (4) +* On entry, the seed of the random number generator; the array +* elements must be between 0 and 4095, and ISEED(4) must be +* odd. +* On exit, the seed is updated. +* +* Further Details +* =============== +* +* This routine uses a multiplicative congruential method with modulus +* 2**48 and multiplier 33952834046453 (see G.S.Fishman, +* 'Multiplicative congruential random number generators with modulus +* 2**b: an exhaustive analysis for b = 32 and a partial analysis for +* b = 48', Math. Comp. 189, pp 331-344, 1990). +* +* 48-bit integers are stored in 4 integer array elements with 12 bits +* per element. Hence the routine is portable across machines with +* integers of 32 bits or more. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER M1, M2, M3, M4 + PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + INTEGER IPW2 + DOUBLE PRECISION R + PARAMETER ( IPW2 = 4096, R = ONE / IPW2 ) +* .. +* .. Local Scalars .. + INTEGER IT1, IT2, IT3, IT4 +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MOD +* .. +* .. Executable Statements .. +* +* multiply the seed by the multiplier modulo 2**48 +* + IT4 = ISEED( 4 )*M4 + IT3 = IT4 / IPW2 + IT4 = IT4 - IPW2*IT3 + IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3 + IT2 = IT3 / IPW2 + IT3 = IT3 - IPW2*IT2 + IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2 + IT1 = IT2 / IPW2 + IT2 = IT2 - IPW2*IT1 + IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 + + $ ISEED( 4 )*M1 + IT1 = MOD( IT1, IPW2 ) +* +* return updated seed +* + ISEED( 1 ) = IT1 + ISEED( 2 ) = IT2 + ISEED( 3 ) = IT3 + ISEED( 4 ) = IT4 +* +* convert 48-bit integer to a real number in the interval (0,1) +* + DLARAN = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* + $ ( DBLE( IT4 ) ) ) ) ) + RETURN +* +* End of DLARAN +* + END --- /dev/null +++ blacs-pvm-1.1/TESTING/btprim_MPL.f @@ -0,0 +1,332 @@ + SUBROUTINE BTSETUP( MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM, + $ TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, + $ IAM, NNODES ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX + INTEGER MEMLEN, CMEMLEN, OUTNUM, IAM, NNODES +* .. +* .. Array Arguments .. + INTEGER MEM(MEMLEN) + CHARACTER*1 CMEM(CMEMLEN) +* .. +* +* Purpose +* ======= +* BTSETUP: Does nothing on non-PVM platforms +* +* ==================================================================== +* .. Executable Statements .. + RETURN + END +* + INTEGER FUNCTION IBTMYPROC() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTMYPROC: returns a process number between 0 .. NPROCS-1. On +* systems not natively in this numbering scheme, translates to it. +* +* ==================================================================== +* .. External Subroutines .. + EXTERNAL MP_ENVIRON +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. + CALL MP_ENVIRON(I, J) + IBTMYPROC = J + RETURN +* +* End of IBTMYPROC +* + END +* + INTEGER FUNCTION IBTNPROCS() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTNPROCS: returns the number of processes in the machine. +* +* ==================================================================== +* +* .. External Subroutines .. + EXTERNAL MP_ENVIRON +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + CALL MP_ENVIRON(I, J) + IBTNPROCS = I +* + RETURN +* +* End of IBTNPROCS +* + END +* + SUBROUTINE BTSEND(DTYPE, N, BUFF, DEST, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, DEST, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTSEND: Communication primitive used to send messages independent +* of the BLACS. May safely be either locally or globally blocking. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is (same as PVM): +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (input) accepted as INTEGER array +* The array to be communicated. Its true data type is +* indicated by DTYPE. +* +* DEST (input) INTEGER +* The destination of the message. +* +* MSGID (input) INTEGER +* The message ID (AKA message tag or type). +* +* ===================================================================== +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. Local Scalars .. + INTEGER I, IAM, LENGTH + INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Save statement .. + SAVE ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Data statements .. + DATA ISIZE /-50/ +* .. +* .. Executable Statements .. +* +* On first call, initialize size variables +* + IF( ISIZE .LT. 0 ) THEN + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') + DSIZE = IBTSIZEOF('D') + CSIZE = IBTSIZEOF('C') + ZSIZE = IBTSIZEOF('Z') + END IF +* +* Figure length of buffer +* + IF( DTYPE .EQ. 1 ) THEN + LENGTH = N + ELSE IF( DTYPE .EQ. 3 ) THEN + LENGTH = N * ISIZE + ELSE IF( DTYPE .EQ. 4 ) THEN + LENGTH = N * SSIZE + ELSE IF( DTYPE .EQ. 5 ) THEN + LENGTH = N * CSIZE + ELSE IF( DTYPE .EQ. 6 ) THEN + LENGTH = N * DSIZE + ELSE IF( DTYPE .EQ. 7 ) THEN + LENGTH = N * ZSIZE + END IF +* +* Send the message +* + IF(DEST .EQ. -1) THEN + IAM = IBTMYPROC() + DO 10 I = 0, IBTNPROCS()-1 + IF( I .NE. IAM ) + $ CALL MP_BSEND(BUFF, LENGTH, I, MSGID) + 10 CONTINUE + ELSE + CALL MP_BSEND(BUFF, LENGTH, DEST, MSGID) + END IF +* + RETURN +* +* End BTSEND +* + END +* + SUBROUTINE BTRECV(DTYPE, N, BUFF, SRC, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, SRC, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTRECV: Globally blocking receive. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is: +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (output) INTEGER +* The buffer to receive into. +* +* SRC (input) INTEGER +* The source of the message. +* +* MSGID (input) INTEGER +* The message ID. +* +* ===================================================================== +* +* .. External Functions .. + INTEGER IBTSIZEOF + EXTERNAL IBTSIZEOF +* .. +* .. Local Scalars .. + INTEGER LENGTH, TMP + INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Save statement .. + SAVE ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE +* .. +* .. Data statements .. + DATA ISIZE /-50/ +* .. +* .. Executable Statements .. +* +* On first call, initialize size variables +* + IF( ISIZE .LT. 0 ) THEN + ISIZE = IBTSIZEOF('I') + SSIZE = IBTSIZEOF('S') + DSIZE = IBTSIZEOF('D') + CSIZE = IBTSIZEOF('C') + ZSIZE = IBTSIZEOF('Z') + END IF +* +* Figure length of buffer +* + IF( DTYPE .EQ. 1 ) THEN + LENGTH = N + ELSE IF( DTYPE .EQ. 3 ) THEN + LENGTH = N * ISIZE + ELSE IF( DTYPE .EQ. 4 ) THEN + LENGTH = N * SSIZE + ELSE IF( DTYPE .EQ. 5 ) THEN + LENGTH = N * CSIZE + ELSE IF( DTYPE .EQ. 6 ) THEN + LENGTH = N * DSIZE + ELSE IF( DTYPE .EQ. 7 ) THEN + LENGTH = N * ZSIZE + END IF +* +* Receive the message +* + CALL MP_BRECV(BUFF, LENGTH, SRC, MSGID, TMP) +* + RETURN +* +* End of BTRECV +* + END +* + INTEGER FUNCTION IBTSIZEOF(TYPE) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 TYPE +* .. +* +* Purpose +* ======= +* IBTSIZEOF: Returns the size, in bytes, of the 5 data types. +* If your platform has a different size for DOUBLE PRECISION, you must +* change the parameter statement in BLACSTEST as well. +* +* Arguments +* ========= +* TYPE (input) CHARACTER*1 +* The data type who's size is to be determined: +* 'I' : INTEGER +* 'S' : SINGLE PRECISION REAL +* 'D' : DOUBLE PRECISION REAL +* 'C' : SINGLE PRECISION COMPLEX +* 'Z' : DOUBLE PRECISION COMPLEX +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Local Scalars .. + INTEGER LENGTH +* .. +* .. Executable Statements .. +* + IF( LSAME(TYPE, 'I') ) THEN + LENGTH = 4 + ELSE IF( LSAME(TYPE, 'S') ) THEN + LENGTH = 4 + ELSE IF( LSAME(TYPE, 'D') ) THEN + LENGTH = 8 + ELSE IF( LSAME(TYPE, 'C') ) THEN + LENGTH = 8 + ELSE IF( LSAME(TYPE, 'Z') ) THEN + LENGTH = 16 + END IF + IBTSIZEOF = LENGTH +* + RETURN + END --- /dev/null +++ blacs-pvm-1.1/TESTING/btprim_MPI.f @@ -0,0 +1,377 @@ + SUBROUTINE BTSETUP( MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM, + $ TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, + $ IAM, NNODES ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX + INTEGER MEMLEN, CMEMLEN, OUTNUM, IAM, NNODES +* .. +* .. Array Arguments .. + INTEGER MEM(MEMLEN) + CHARACTER*1 CMEM(CMEMLEN) +* .. +* +* Purpose +* ======= +* BTSETUP: Sets up communicator and initiliazes MPI if needed. +* +* ==================================================================== +* +* .. +* .. Local Scalars + LOGICAL INIT +* .. +* .. Include Files .. + INCLUDE 'mpif.h' +* .. +* .. Common Blocks .. + COMMON /BTMPI/ BTCOMM, IERR + INTEGER BTCOMM, IERR +* .. +* .. Executable Statements .. +* + IERR = 0 + CALL MPI_INITIALIZED(INIT, IERR) + IF (.NOT.INIT) CALL MPI_INIT(IERR) + IF (IERR.NE.0) CALL BTMPIERR("mpi_init", IERR) + CALL MPI_COMM_DUP(MPI_COMM_WORLD, BTCOMM, IERR) + IF (IERR.NE.0) CALL BTMPIERR("MPI_COMM_DUP", IERR) +* + RETURN + END + INTEGER FUNCTION IBTMYPROC() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTMYPROC: returns a process number between 0 .. NPROCS-1. On +* systems not natively in this numbering scheme, translates to it. +* +* ==================================================================== +* .. +* .. Include Files .. + INCLUDE 'mpif.h' +* .. +* .. Local Scalars .. + INTEGER RANK +* .. +* .. Common Blocks .. + COMMON /BTMPI/ BTCOMM, IERR + INTEGER BTCOMM, IERR +* .. +* .. Executable Statements .. +* + CALL MPI_COMM_RANK(BTCOMM, RANK, IERR) + IF (IERR.NE.0) CALL BTMPIERR("MPI_COMM_RANK", IERR) + IBTMYPROC = RANK + RETURN +* +* End of IBTMYPROC +* + END +* + INTEGER FUNCTION IBTNPROCS() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTNPROCS: returns the number of processes in the machine. +* +* ==================================================================== +* .. +* .. Include Files .. + INCLUDE 'mpif.h' +* .. +* .. Local Scalars .. + INTEGER NPROC +* .. +* .. Common Blocks .. + COMMON /BTMPI/ BTCOMM, IERR + INTEGER BTCOMM, IERR +* .. +* .. Executable Statements .. +* + CALL MPI_COMM_SIZE(BTCOMM, NPROC, IERR) + IF (IERR.NE.0) CALL BTMPIERR("MPI_COMM_SIZE", IERR) + IBTNPROCS = NPROC +* + RETURN +* +* End of IBTNPROCS +* + END +* + SUBROUTINE BTSEND(DTYPE, N, BUFF, DEST, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, DEST, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTSEND: Communication primitive used to send messages independent +* of the BLACS. May safely be either locally or globally blocking. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is (same as PVM): +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (input) accepted as INTEGER array +* The array to be communicated. Its true data type is +* indicated by DTYPE. +* +* DEST (input) INTEGER +* The destination of the message. +* +* MSGID (input) INTEGER +* The message ID (AKA message tag or type). +* +* ===================================================================== +* .. External Functions .. + INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF + EXTERNAL IBTMYPROC, IBTNPROCS, IBTSIZEOF +* .. +* .. Local Scalars .. + INTEGER I, IAM, MPIDTYPE +* .. +* .. Include Files .. + INCLUDE 'mpif.h' +* .. +* .. Common Blocks .. + COMMON /BTMPI/ BTCOMM, IERR + INTEGER BTCOMM, IERR +* + IF( DTYPE .EQ. 1 ) THEN + MPIDTYPE = MPI_BYTE + ELSE IF( DTYPE .EQ. 3 ) THEN + MPIDTYPE = MPI_INTEGER + ELSE IF( DTYPE .EQ. 4 ) THEN + MPIDTYPE = MPI_REAL + ELSE IF( DTYPE .EQ. 5 ) THEN + MPIDTYPE = MPI_COMPLEX + ELSE IF( DTYPE .EQ. 6 ) THEN + MPIDTYPE = MPI_DOUBLE_PRECISION + ELSE IF( DTYPE .EQ. 7 ) THEN + MPIDTYPE = MPI_DOUBLE_COMPLEX + END IF +* +* Send the message +* + IF( DEST .EQ. -1 ) THEN + IAM = IBTMYPROC() + DO 10 I = 0, IBTNPROCS()-1 + IF( I .NE. IAM ) THEN + CALL MPI_SEND(BUFF, N, MPIDTYPE, I, 0, BTCOMM, IERR) + IF (IERR.NE.0) CALL BTMPIERR("MPI_SEND", IERR) + END IF + 10 CONTINUE + ELSE + CALL MPI_SEND(BUFF, N, MPIDTYPE, DEST, 0, BTCOMM, IERR) + IF (IERR.NE.0) CALL BTMPIERR("MPI_SEND", IERR) + END IF +* + RETURN +* +* End BTSEND +* + END +* + SUBROUTINE BTRECV(DTYPE, N, BUFF, SRC, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, SRC, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTRECV: Globally blocking receive. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is: +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (output) INTEGER +* The buffer to receive into. +* +* SRC (input) INTEGER +* The source of the message. +* +* MSGID (input) INTEGER +* The message ID. +* +* ===================================================================== +* .. +* .. Local Scalars .. + INTEGER MPIDTYPE +* .. +* .. Include Files .. + INCLUDE 'mpif.h' +* .. +* .. Local Arrays .. + INTEGER STAT(MPI_STATUS_SIZE) +* .. +* .. Common Blocks .. + COMMON /BTMPI/ BTCOMM, IERR + INTEGER BTCOMM, IERR +* + IF( DTYPE .EQ. 1 ) THEN + MPIDTYPE = MPI_BYTE + ELSE IF( DTYPE .EQ. 3 ) THEN + MPIDTYPE = MPI_INTEGER + ELSE IF( DTYPE .EQ. 4 ) THEN + MPIDTYPE = MPI_REAL + ELSE IF( DTYPE .EQ. 5 ) THEN + MPIDTYPE = MPI_COMPLEX + ELSE IF( DTYPE .EQ. 6 ) THEN + MPIDTYPE = MPI_DOUBLE_PRECISION + ELSE IF( DTYPE .EQ. 7 ) THEN + MPIDTYPE = MPI_DOUBLE_COMPLEX + END IF +* + CALL MPI_RECV( BUFF, N, MPIDTYPE, SRC, 0, BTCOMM, STAT, IERR ) + IF (IERR.NE.0) CALL BTMPIERR("MPI_RECV", IERR) +* + RETURN +* +* End of BTRECV +* + END +* + INTEGER FUNCTION IBTSIZEOF(TYPE) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 TYPE +* .. +* +* Purpose +* ======= +* IBTSIZEOF: Returns the size, in bytes, of the 5 data types. +* If your platform has a different size for DOUBLE PRECISION, you must +* change the parameter statement in BLACSTEST as well. +* +* Arguments +* ========= +* TYPE (input) CHARACTER*1 +* The data type who's size is to be determined: +* 'I' : INTEGER +* 'S' : SINGLE PRECISION REAL +* 'D' : DOUBLE PRECISION REAL +* 'C' : SINGLE PRECISION COMPLEX +* 'Z' : DOUBLE PRECISION COMPLEX +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Include Files .. + INCLUDE 'mpif.h' +* .. +* .. Common Blocks .. + COMMON /BTMPI/ BTCOMM, IERR + INTEGER BTCOMM, IERR +* .. +* .. Local Scalars .. + INTEGER LENGTH + LOGICAL INIT + DATA INIT /.FALSE./ +* .. +* .. Executable Statements .. +* +* +* Initialize MPI, if necessary +* + IF (.NOT.INIT) THEN + CALL MPI_INITIALIZED(INIT, IERR) + IF (.NOT.INIT) CALL MPI_INIT(IERR) + IF (IERR.NE.0) CALL BTMPIERR("mpi_init", IERR) + INIT = .TRUE. + END IF +* + IF( LSAME(TYPE, 'I') ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, LENGTH, IERR ) + IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR) + ELSE IF( LSAME(TYPE, 'S') ) THEN + CALL MPI_TYPE_SIZE( MPI_REAL, LENGTH, IERR ) + IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR) + ELSE IF( LSAME(TYPE, 'D') ) THEN + CALL MPI_TYPE_SIZE( MPI_DOUBLE_PRECISION, LENGTH, IERR ) + IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR) + ELSE IF( LSAME(TYPE, 'C') ) THEN + CALL MPI_TYPE_SIZE( MPI_COMPLEX, LENGTH, IERR ) + IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR) + ELSE IF( LSAME(TYPE, 'Z') ) THEN + CALL MPI_TYPE_SIZE( MPI_DOUBLE_COMPLEX, LENGTH, IERR ) + IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR) + END IF + IBTSIZEOF = LENGTH +* + RETURN + END + SUBROUTINE BTMPIERR(ROUT, IERR0) + CHARACTER*(*) ROUT + INTEGER IERR0 +* .. +* .. Include Files .. + INCLUDE 'mpif.h' +* .. +* .. Common Blocks .. + COMMON /BTMPI/ BTCOMM, IERR + INTEGER BTCOMM, IERR +* + WRITE(*,1000) ROUT, IERR + CALL MPI_ABORT(BTCOMM, IERR0, IERR) +* + 1000 FORMAT('Error #',I20,' from routine ',A) + RETURN + END --- /dev/null +++ blacs-pvm-1.1/TESTING/btprim_PVM.f @@ -0,0 +1,481 @@ + SUBROUTINE BTSETUP( MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM, + $ TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, + $ IAM, NNODES ) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX + INTEGER MEMLEN, CMEMLEN, OUTNUM, IAM, NNODES +* .. +* .. Array Arguments .. + INTEGER MEM(MEMLEN) + CHARACTER*1 CMEM(CMEMLEN) +* .. +* +* Purpose +* ======= +* BTSETUP: Fills in process number array, and sets up machine on +* dynamic systems. +* +* Arguments +* ========= +* MEM (input) INTEGER array, dimension MEMSIZE +* Scratch pad memory area. +* +* MEMLEN (input) INTEGER +* Number of safe elements in MEM. +* +* CMEM (input) CHARACTER array, dimension CMEMSIZE +* Scratch pad memory area. +* +* CMEMLEN (input) INTEGER +* Number of safe elements in MEM. +* +* OUTNUM (input/output) INTEGER +* Unit number of output file for top level error information. +* Input for process 0. Set to zero as output for all other +* processes as a safety precaution. +* +* TESTSDRV (input) LOGICAL +* Will there be point-to-point tests in this test run? +* +* TESTBSBR (input) LOGICAL +* Will there be broadcast tests in this test run? +* +* TESTCOMB (input) LOGICAL +* Will there be combine-operator tests in this test run? +* +* TESTAUX (input) LOGICAL +* Will there be auxiliary tests in this test run? +* +* IAM (input/output) INTEGER +* This process's node number. +* +* NNODES (input/output) INTEGER +* Number of processes that are started up by this subroutine. +* +* ==================================================================== +* +* .. Local Scalars .. + INTEGER I, CONTEXT, MEMUSED, CMEMUSED, NGRID, PPTR, QPTR +* .. +* .. External Functions .. + INTEGER BLACS_PNUM + EXTERNAL BLACS_PNUM +* .. +* .. External Subroutines .. + EXTERNAL BLACS_SETUP, BLACS_GRIDINIT, BLACS_GRIDEXIT +* .. +* .. Common blocks .. + COMMON /BTPNUM/ BTPNUMS +* .. +* .. Arrays in Common .. + INTEGER BTPNUMS(0:999) +* .. +* .. Executable Statements .. +* + IF( NNODES .GT. 0 ) RETURN + IF ( IAM .EQ. 0 ) THEN + IF ( TESTSDRV ) THEN +* +* Determine the max number of nodes required by a SDRV tests +* + CALL RDSDRV( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, + $ OUTNUM ) + IF( (MEMUSED + 24) .GT. MEMLEN ) THEN + WRITE(OUTNUM, *) 'Not enough memory to read in sdrv.dat' + STOP + END IF +* + I = MEMUSED + 1 + CALL BTUNPACK( 'SDRV', MEM, MEMUSED, MEM(I+1), MEM(I+2), + $ MEM(I+22), MEM(I+23), MEM(I+12), MEM(I+20), + $ MEM(I+3), MEM(I+13), NGRID, MEM(I+4), + $ MEM(I+14), MEM(I+21), MEM(I+5), MEM(I+15), + $ MEM(I+6), MEM(I+16), MEM(I+7), MEM(I+17), + $ MEM(I+8), MEM(I+18), MEM(I+9), MEM(I+19), + $ MEM(I+11), PPTR, QPTR ) +* + DO 10 I = 0, NGRID-1 + NNODES = MAX0( MEM(PPTR+I) * MEM(QPTR+I), NNODES ) + 10 CONTINUE + END IF + IF( TESTBSBR ) THEN +* +* Determine the maximum number of nodes required by a +* broadcast test case +* + CALL RDBSBR( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, + $ OUTNUM ) + I = MEMUSED + 1 + CALL BTUNPACK( 'BSBR', MEM, MEMUSED, MEM(I+1), MEM(I+2), + $ MEM(I+22), MEM(I+23), MEM(I+12), MEM(I+20), + $ MEM(I+3), MEM(I+13), NGRID, MEM(I+4), + $ MEM(I+14), MEM(I+21), MEM(I+5), MEM(I+15), + $ MEM(I+6), MEM(I+16), MEM(I+7), MEM(I+17), + $ MEM(I+8), MEM(I+18), MEM(I+9), MEM(I+19), + $ MEM(I+11), PPTR, QPTR ) + DO 20 I = 0, NGRID-1 + NNODES = MAX0( MEM(PPTR+I) * MEM(QPTR+I), NNODES ) + 20 CONTINUE +* + END IF + IF( TESTCOMB ) THEN +* +* Determine the maximum number of nodes required by a +* combine test case +* + CALL RDCOMB( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, + $ OUTNUM ) + I = MEMUSED + 1 + CALL BTUNPACK( 'COMB', MEM, MEMUSED, MEM(I+1), MEM(I+2), + $ MEM(I+22), MEM(I+23), MEM(I+12), MEM(I+20), + $ MEM(I+3), MEM(I+13), NGRID, MEM(I+4), + $ MEM(I+14), MEM(I+21), MEM(I+5), MEM(I+15), + $ MEM(I+6), MEM(I+16), MEM(I+7), MEM(I+17), + $ MEM(I+8), MEM(I+18), MEM(I+9), MEM(I+19), + $ MEM(I+11), PPTR, QPTR ) +* + DO 30 I = 0, NGRID-1 + NNODES = MAX0( MEM(PPTR+I) * MEM(QPTR+I), NNODES ) + 30 CONTINUE + END IF + END IF +* +* If we run auxiliary tests, must have at least two nodes, +* otherwise, minimum is 1 +* + IF( TESTAUX ) THEN + NNODES = MAX0( NNODES, 2 ) + ELSE + NNODES = MAX0( NNODES, 1 ) + END IF +* + CALL BLACS_SETUP( IAM, NNODES ) +* +* We've buried a PNUM array in the common block above, and here +* we initialize it. The reason for carrying this along is so that +* the TSEND and TRECV subroutines can report test results back to +* the first process, which can then be the sole process +* writing output files. +* + CALL BLACS_GET( 0, 0, CONTEXT ) + CALL BLACS_GRIDINIT( CONTEXT, 'r', 1, NNODES ) +* + DO 40 I = 0, NNODES-1 + BTPNUMS(I) = BLACS_PNUM( CONTEXT, 0, I ) + 40 CONTINUE +* + CALL BLACS_GRIDEXIT( CONTEXT ) +* + RETURN +* +* End of BTSETUP. +* + END +* + INTEGER FUNCTION IBTMYPROC() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTMYPROC: returns a process number between 0 .. NPROCS-1. On +* systems not natively in this numbering scheme, translates to it. +* +* ==================================================================== +* +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Common blocks .. + COMMON /BTPNUM/ BTPNUMS +* .. +* .. Arrays in Common .. + INTEGER BTPNUMS(0:999) +* .. +* .. Local Scalars .. + INTEGER IAM, I, K +* .. +* .. Save statement .. + SAVE IAM +* .. +* .. Data statements .. + DATA IAM /-1/ +* .. +* .. Executable Statements .. +* + IF (IAM .EQ. -1) THEN + CALL PVMFMYTID(K) + DO 10 I = 0, IBTNPROCS()-1 + IF( K .EQ. BTPNUMS(I) ) IAM = I + 10 CONTINUE + END IF +* + IBTMYPROC = IAM + RETURN +* +* End of IBTMYPROC +* + END +* + INTEGER FUNCTION IBTNPROCS() +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* Purpose +* ======= +* IBTNPROCS: returns the number of processes in the machine. +* +* ==================================================================== +* .. Local Scalars .. + INTEGER IAM, NNODES +* .. +* +* Got to use BLACS, since it set up the machine . . . +* + CALL BLACS_PINFO(IAM, NNODES) + IBTNPROCS = NNODES +* + RETURN +* +* End of IBTNPROCS +* + END +* + SUBROUTINE BTSEND(DTYPE, N, BUFF, DEST, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, DEST, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTSEND: Communication primitive used to send messages independent +* of the BLACS. May safely be either locally or globally blocking. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is (same as PVM): +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (input) accepted as INTEGER array +* The array to be communicated. Its true data type is +* indicated by DTYPE. +* +* DEST (input) INTEGER +* The destination of the message. +* +* MSGID (input) INTEGER +* The message ID (AKA message tag or type). +* +* ===================================================================== +* .. External Functions .. + INTEGER IBTNPROCS + EXTERNAL IBTNPROCS +* .. +* .. Common blocks .. + COMMON /BTPNUM/ BTPNUMS +* .. +* .. Arrays in Common .. + INTEGER BTPNUMS(0:999) +* .. +* .. Include Files .. + INCLUDE 'fpvm3.h' +* .. +* .. Local Scalars .. + INTEGER INFO, PVMTYPE +* .. +* .. Executable Statements .. +* +* Map internal type parameters to PVM +* + IF( DTYPE .EQ. 1 ) THEN + PVMTYPE = BYTE1 + ELSE IF( DTYPE .EQ. 3 ) THEN + PVMTYPE = INTEGER4 + ELSE IF( DTYPE .EQ. 4 ) THEN + PVMTYPE = REAL4 + ELSE IF( DTYPE .EQ. 5 ) THEN + PVMTYPE = COMPLEX8 + ELSE IF( DTYPE .EQ. 6 ) THEN + PVMTYPE = REAL8 + ELSE IF( DTYPE .EQ. 7 ) THEN + PVMTYPE = COMPLEX16 + END IF +* +* pack and send data to specified process +* + CALL PVMFINITSEND(PVMDATADEFAULT, INFO) + CALL PVMFPACK(DTYPE, BUFF, N, 1, INFO) + IF( DEST .EQ. -1 ) THEN + CALL PVMFMCAST(IBTNPROCS(), BTPNUMS, MSGID, INFO) + ELSE + CALL PVMFSEND(BTPNUMS(DEST) , MSGID, INFO) + ENDIF +* + RETURN +* +* End BTSEND +* + END +* + SUBROUTINE BTRECV(DTYPE, N, BUFF, SRC, MSGID) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* +* .. Scalar Arguments .. + INTEGER N, DTYPE, SRC, MSGID +* .. +* .. Array Arguments .. + REAL BUFF(*) +* .. +* +* PURPOSE +* ======= +* BTRECV: Globally blocking receive. +* +* Arguments +* ========= +* DTYPE (input) INTEGER +* Indicates what data type BUFF is: +* 1 = RAW BYTES +* 3 = INTEGER +* 4 = SINGLE PRECISION REAL +* 6 = DOUBLE PRECISION REAL +* 5 = SINGLE PRECISION COMPLEX +* 7 = DOUBLE PRECISION COMPLEX +* +* N (input) INTEGER +* The number of elements of type DTYPE in BUFF. +* +* BUFF (output) INTEGER +* The buffer to receive into. +* +* SRC (input) INTEGER +* The source of the message. +* +* MSGID (input) INTEGER +* The message ID. +* +* ===================================================================== +* +* .. Common blocks .. + COMMON /BTPNUM/ BTPNUMS +* .. +* .. Arrays in Common .. + INTEGER BTPNUMS(0:999) +* .. +* .. Include Files .. + INCLUDE 'fpvm3.h' +* .. +* .. Local Scalars .. + INTEGER INFO, PVMTYPE +* .. +* .. Executable Statements .. +* +* Map internal type parameters to PVM +* + IF( DTYPE .EQ. 1 ) THEN + PVMTYPE = BYTE1 + ELSE IF( DTYPE .EQ. 3 ) THEN + PVMTYPE = INTEGER4 + ELSE IF( DTYPE .EQ. 4 ) THEN + PVMTYPE = REAL4 + ELSE IF( DTYPE .EQ. 5 ) THEN + PVMTYPE = COMPLEX8 + ELSE IF( DTYPE .EQ. 6 ) THEN + PVMTYPE = REAL8 + ELSE IF( DTYPE .EQ. 7 ) THEN + PVMTYPE = COMPLEX16 + END IF + CALL PVMFRECV(BTPNUMS(SRC), MSGID, INFO) + CALL PVMFUNPACK(DTYPE, BUFF, N, 1, INFO) +* .. +* .. Local Scalars .. +* + RETURN +* +* End of BTRECV +* + END +* + INTEGER FUNCTION IBTSIZEOF(TYPE) +* +* -- BLACS tester (version 1.0) -- +* University of Tennessee +* December 15, 1994 +* +* .. Scalar Arguments .. + CHARACTER*1 TYPE +* .. +* +* Purpose +* ======= +* IBTSIZEOF: Returns the size, in bytes, of the 5 data types. +* If your platform has a different size for DOUBLE PRECISION, you must +* change the parameter statement in BLACSTEST as well. +* +* Arguments +* ========= +* TYPE (input) CHARACTER*1 +* The data type who's size is to be determined: +* 'I' : INTEGER +* 'S' : SINGLE PRECISION REAL +* 'D' : DOUBLE PRECISION REAL +* 'C' : SINGLE PRECISION COMPLEX +* 'Z' : DOUBLE PRECISION COMPLEX +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Local Scalars .. + INTEGER LENGTH +* .. +* .. Executable Statements .. +* + IF( LSAME(TYPE, 'I') ) THEN + LENGTH = 4 + ELSE IF( LSAME(TYPE, 'S') ) THEN + LENGTH = 4 + ELSE IF( LSAME(TYPE, 'D') ) THEN + LENGTH = 8 + ELSE IF( LSAME(TYPE, 'C') ) THEN + LENGTH = 8 + ELSE IF( LSAME(TYPE, 'Z') ) THEN + LENGTH = 16 + END IF + IBTSIZEOF = LENGTH +* + RETURN + END --- /dev/null +++ blacs-pvm-1.1/TESTING/bt.dat @@ -0,0 +1,10 @@ +'Sample BLACS tester run' Comment line +6 device out +'blacstest.out' output fname +'T' Run SDRV? +'T' Run BSBR? +'T' Run COMB? +'T' Run AUX? +5 Number of precisions +'I' 'S' 'D' 'C' 'Z' Values for precision +0 Verbosity level --- /dev/null +++ blacs-pvm-1.1/TESTING/README @@ -0,0 +1,11 @@ +(1) To compile, just type "make". You must first edit and correct the + file BLACS/Bmake.inc. Sample Bmake.inc's can be found in the + BLACS/BMAKES directories. See the paper "Installing and testing the BLACS" + for details. + +(2) Type "make clean" to get rid of old .o files. + +(3) The file blacstest.f is extremely large (roughly 20,000 lines), + and this may be too large to compile on some systems. If you have this + problem, a slight modification to the BLACS/TESTING Makefile should allow + you to split blacstest.f into smaller files. --- /dev/null +++ blacs-pvm-1.1/TESTING/sdrv.dat @@ -0,0 +1,16 @@ +5 Number of shapes +'G' 'U' 'U' 'L' 'L' UPLO +'E' 'U' 'N' 'U' 'N' DIAG +5 Number of matrices +2 1 25 13 0 M +2 7 19 32 0 N +2 3 25 14 1 LDASRC +3 2 25 22 1 LDADEST +1 Number of src/dest pairs +0 1 3 0 RSRC +0 0 0 2 CSRC +0 1 2 0 RDEST +1 1 0 0 CDEST +3 Number of grids +2 4 1 NPROW +2 1 4 NPCOL --- blacs-pvm-1.1.orig/SRC/PVM/Makefile +++ blacs-pvm-1.1/SRC/PVM/Makefile @@ -161,6 +161,15 @@ Cblacs_barrier_.C : blacs_barrier_.C .c.C: $(CC) -o C$*.o -c $(CCFLAGS) $(BLACSDEFS) -DCallFromC $< mv C$*.o $*.C + +# blacs_setup_.c compiles only without optimzation, +# libc6: 2.1.1-1, gcc: 2.91.66-1 +blacs_setup_.o: blacs_setup_.c + $(CC) -c $(BLACSDEFS) $< +blacs_setup_.C: blacs_setup_.c + $(CC) -o C$*.o -c $(BLACSDEFS) -DCallFromC $< + mv C$*.o $*.C + .c.o: $(CC) -c $(CCFLAGS) $(BLACSDEFS) $< debian/patches/03-TESTING_Makefile.patch0000644000000000000000000000456411640164103014775 0ustar --- /dev/null +++ blacs-pvm-1.1/TESTING/Makefile @@ -0,0 +1,72 @@ +include ../Bmake.inc + +# --------------------------------------------------------------------- +# The file tools.f contains some LAPACK routines that the tester calls. +# If you have ScaLAPACK, you may point to your tools library instead +# of compiling this file. +# --------------------------------------------------------------------- + tools = tools.o + +exe : all +ctest : $(CTESTexe) dat +ftest : $(FTESTexe) dat +all : $(FTESTexe) $(CTESTexe) dat +dat : $(TESTdir)/bt.dat $(TESTdir)/sdrv.dat $(TESTdir)/bsbr.dat \ + $(TESTdir)/comb.dat + +obj = blacstest.o btprim_$(COMMLIB).o + +$(CTESTexe): $(obj) $(tools) + $(CC) -c $(CCFLAGS) -DBTCINTFACE $(BLACSDEFS) Cbt.c + $(F77LOADER) $(F77LOADFLAGS) -o $@ $(obj) $(tools) Cbt.o $(BTLIBS) + +$(FTESTexe): $(obj) $(tools) + $(F77LOADER) $(F77LOADFLAGS) -o $@ $(obj) $(tools) $(BTLIBS) + +# -------------------------------------------------------------------- +# The files tools.f and blacstest.f are compiled without optimization. +# Tools.f contains the LAPACK routines slamch and dlamch, which only +# operate correctly for low-levels of optimization. Blacstest.f is +# extremely large, and optimizing it takes a long time. More +# importantly, the sun's f77 compiler seems to produce errors in +# trying to optimize such a large file. We therefore insist that it +# also not be optimized. +# -------------------------------------------------------------------- +tools.o : tools.f + $(F77) $(F77NO_OPTFLAGS) -c $*.f + +blacstest.o : blacstest.f + $(F77) $(F77NO_OPTFLAGS) -c $*.f + +$(TESTdir)/bt.dat : $(BTOPdir)/TESTING/bt.dat + cp $(BTOPdir)/TESTING/bt.dat $(TESTdir)/ + +$(TESTdir)/sdrv.dat : $(BTOPdir)/TESTING/sdrv.dat + cp $(BTOPdir)/TESTING/sdrv.dat $(TESTdir)/ + +$(TESTdir)/bsbr.dat : $(BTOPdir)/TESTING/bsbr.dat + cp $(BTOPdir)/TESTING/bsbr.dat $(TESTdir)/ + +$(TESTdir)/comb.dat : $(BTOPdir)/TESTING/comb.dat + cp $(BTOPdir)/TESTING/comb.dat $(TESTdir)/ + +btprim_MPI.o : btprim_MPI.f + make mpif.h + $(F77) -c $(F77FLAGS) $*.f + +btprim_PVM.o : btprim_PVM.f + make fpvm3.h + $(F77) -c $(F77FLAGS) $*.f + +mpif.h : $(MPIINCdir)/mpif.h + rm -f mpif.h + ln -s $(MPIINCdir)/mpif.h mpif.h + +fpvm3.h : $(PVMINCdir)/fpvm3.h + rm -f fpvm3.h + ln -s $(PVMINCdir)/fpvm3.h fpvm3.h + +clean : + rm -f $(obj) tools.o Cbt.o mpif.h fpvm3.h + +.f.o: ; $(F77) -c $(F77FLAGS) $*.f debian/patches/01-Makefile.patch0000644000000000000000000000046111640163756013603 0ustar --- blacs-pvm-1.1.orig/Makefile +++ blacs-pvm-1.1/Makefile @@ -12,10 +12,6 @@ help : all : mpi cmmd mpl nx pvm tester cleanall: - ( cd TESTING ; make clean ) - ( cd SRC/CMMD ; make clean ) - ( cd SRC/MPL ; make clean ) - ( cd SRC/NX ; make clean ) ( cd SRC/PVM ; make clean ) testing: tester debian/patches/series0000644000000000000000000000017411640165026012035 0ustar 01-Makefile.patch 02-Bmake.patch 03-TESTING_Makefile.patch 04-TESTING_Cbt.patch 05-TESTING_btprim_NX.patch 06-TESTING.patch debian/patches/04-TESTING_Cbt.patch0000644000000000000000000004113711640164211013766 0ustar --- /dev/null +++ blacs-pvm-1.1/TESTING/Cbt.c @@ -0,0 +1,973 @@ +#ifdef BTCINTFACE +#include "Cbt.h" + +void blacs_gridinit_(ConTxt, order, nprow, npcol) +int *ConTxt; +char *order; +int *nprow; +int *npcol; +{ + void Cblacs_gridinit(); + + Cblacs_gridinit(ConTxt, order, *nprow, *npcol); +} + +void blacs_setup_(mypnum, nprocs) +int *mypnum; +int *nprocs; +{ + void Cblacs_setup(); + Cblacs_setup(mypnum, nprocs); +} + +void blacs_pinfo_(mypnum, nprocs) +int *mypnum; +int *nprocs; +{ + void Cblacs_pinfo(); + Cblacs_pinfo(mypnum, nprocs); +} + +void blacs_gridmap_(ConTxt, usermap, ldup, nprow, npcol) +int *ConTxt; +int *usermap; +int *ldup; +int *nprow; +int *npcol; +{ + void Cblacs_gridmap(); + Cblacs_gridmap(ConTxt, usermap, *ldup, *nprow, *npcol); +} + +void blacs_gridexit_(ConTxt) +int *ConTxt; +{ + void Cblacs_gridexit(); + Cblacs_gridexit(*ConTxt); +} + +void blacs_abort_(ConTxt, ErrNo) +int *ConTxt; +int *ErrNo; +{ + void Cblacs_abort(); + Cblacs_abort(*ConTxt, *ErrNo); +} + +void blacs_exit_(NotDone) +int *NotDone; +{ + void Cblacs_exit(); + Cblacs_exit(*NotDone); +} + +void blacs_freebuff_(ConTxt, Wait) +int *ConTxt; +int *Wait; +{ + void Cblacs_freebuff(); + Cblacs_freebuff(*ConTxt, *Wait); +} + +void blacs_gridinfo_(ConTxt, nprow, npcol, myrow, mycol) +int *ConTxt; +int *nprow; +int *npcol; +int *myrow; +int *mycol; +{ + void Cblacs_gridinfo(); + Cblacs_gridinfo(*ConTxt, nprow, npcol, myrow, mycol); +} + +void blacs_barrier_(ConTxt, scope) +int *ConTxt; +char *scope; +{ + void Cblacs_barrier(); + Cblacs_barrier(*ConTxt, scope); +} + +int blacs_pnum_(ConTxt, prow, pcol) +int *ConTxt; +int *prow; +int *pcol; +{ + int Cblacs_pnum(); + return( Cblacs_pnum(*ConTxt, *prow, *pcol) ); +} + +void blacs_pcoord_(ConTxt, nodenum, prow, pcol) +int *ConTxt; +int *nodenum; +int *prow; +int *pcol; +{ + void Cblacs_pcoord(); + Cblacs_pcoord(*ConTxt, *nodenum, prow, pcol); +} + +void blacs_get_(ConTxt, what, I) +int *ConTxt; +int *what; +int *I; +{ + void Cblacs_get(); + Cblacs_get(*ConTxt, *what, I); +} + +void blacs_set_(ConTxt, what, I) +int *ConTxt; +int *what; +int *I; +{ + void Cblacs_set(); + Cblacs_set(*ConTxt, *what, I); +} + + +void igesd2d_(ConTxt, m, n, A, lda, rdest, cdest) +int *ConTxt; +int *m; +int *n; +int *A; +int *lda; +int *rdest; +int *cdest; +{ + void Cigesd2d(); + Cigesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest); +} + +void igerv2d_(ConTxt, m, n, A, lda, rsrc, csrc) +int *ConTxt; +int *m; +int *n; +int *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cigerv2d(); + Cigerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc); +} + +void igebs2d_(ConTxt, scope, top, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +int *A; +int *lda; +{ + void Cigebs2d(); + Cigebs2d(*ConTxt, scope, top, *m, *n, A, *lda); +} + +void igebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +int *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cigebr2d(); + Cigebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc); +} + +void itrsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +int *A; +int *lda; +int *rdest; +int *cdest; +{ + void Citrsd2d(); + Citrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest); +} + +void itrrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +int *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Citrrv2d(); + Citrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void itrbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +int *A; +int *lda; +{ + void Citrbs2d(); + Citrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda); +} + +void itrbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +int *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Citrbr2d(); + Citrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void igsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +int *A; +int *lda; +int *rdest; +int *cdest; +{ + void Cigsum2d(); + Cigsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest); +} + +void igamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +int *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Cigamx2d(); + Cigamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} + +void igamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +int *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Cigamn2d(); + Cigamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} + +void dgesd2d_(ConTxt, m, n, A, lda, rdest, cdest) +int *ConTxt; +int *m; +int *n; +double *A; +int *lda; +int *rdest; +int *cdest; +{ + void Cdgesd2d(); + Cdgesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest); +} + +void dgerv2d_(ConTxt, m, n, A, lda, rsrc, csrc) +int *ConTxt; +int *m; +int *n; +double *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cdgerv2d(); + Cdgerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc); +} + +void dgebs2d_(ConTxt, scope, top, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +{ + void Cdgebs2d(); + Cdgebs2d(*ConTxt, scope, top, *m, *n, A, *lda); +} + +void dgebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cdgebr2d(); + Cdgebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc); +} + +void dtrsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +double *A; +int *lda; +int *rdest; +int *cdest; +{ + void Cdtrsd2d(); + Cdtrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest); +} + +void dtrrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +double *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cdtrrv2d(); + Cdtrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void dtrbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +double *A; +int *lda; +{ + void Cdtrbs2d(); + Cdtrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda); +} + +void dtrbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +double *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cdtrbr2d(); + Cdtrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void dgsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +int *rdest; +int *cdest; +{ + void Cdgsum2d(); + Cdgsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest); +} + +void dgamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Cdgamx2d(); + Cdgamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} + +void dgamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Cdgamn2d(); + Cdgamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} + +void sgesd2d_(ConTxt, m, n, A, lda, rdest, cdest) +int *ConTxt; +int *m; +int *n; +float *A; +int *lda; +int *rdest; +int *cdest; +{ + void Csgesd2d(); + Csgesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest); +} + +void sgerv2d_(ConTxt, m, n, A, lda, rsrc, csrc) +int *ConTxt; +int *m; +int *n; +float *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Csgerv2d(); + Csgerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc); +} + +void sgebs2d_(ConTxt, scope, top, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +{ + void Csgebs2d(); + Csgebs2d(*ConTxt, scope, top, *m, *n, A, *lda); +} + +void sgebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Csgebr2d(); + Csgebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc); +} + +void strsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +float *A; +int *lda; +int *rdest; +int *cdest; +{ + void Cstrsd2d(); + Cstrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest); +} + +void strrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +float *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cstrrv2d(); + Cstrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void strbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +float *A; +int *lda; +{ + void Cstrbs2d(); + Cstrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda); +} + +void strbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +float *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cstrbr2d(); + Cstrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void sgsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +int *rdest; +int *cdest; +{ + void Csgsum2d(); + Csgsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest); +} + +void sgamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Csgamx2d(); + Csgamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} + +void sgamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Csgamn2d(); + Csgamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} + +void cgesd2d_(ConTxt, m, n, A, lda, rdest, cdest) +int *ConTxt; +int *m; +int *n; +float *A; +int *lda; +int *rdest; +int *cdest; +{ + void Ccgesd2d(); + Ccgesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest); +} + +void cgerv2d_(ConTxt, m, n, A, lda, rsrc, csrc) +int *ConTxt; +int *m; +int *n; +float *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Ccgerv2d(); + Ccgerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc); +} + +void cgebs2d_(ConTxt, scope, top, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +{ + void Ccgebs2d(); + Ccgebs2d(*ConTxt, scope, top, *m, *n, A, *lda); +} + +void cgebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Ccgebr2d(); + Ccgebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc); +} + +void ctrsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +float *A; +int *lda; +int *rdest; +int *cdest; +{ + void Cctrsd2d(); + Cctrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest); +} + +void ctrrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +float *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cctrrv2d(); + Cctrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void ctrbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +float *A; +int *lda; +{ + void Cctrbs2d(); + Cctrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda); +} + +void ctrbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +float *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cctrbr2d(); + Cctrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void cgsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +int *rdest; +int *cdest; +{ + void Ccgsum2d(); + Ccgsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest); +} + +void cgamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Ccgamx2d(); + Ccgamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} + +void cgamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +float *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Ccgamn2d(); + Ccgamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} + +void zgesd2d_(ConTxt, m, n, A, lda, rdest, cdest) +int *ConTxt; +int *m; +int *n; +double *A; +int *lda; +int *rdest; +int *cdest; +{ + void Czgesd2d(); + Czgesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest); +} + +void zgerv2d_(ConTxt, m, n, A, lda, rsrc, csrc) +int *ConTxt; +int *m; +int *n; +double *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Czgerv2d(); + Czgerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc); +} + +void zgebs2d_(ConTxt, scope, top, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +{ + void Czgebs2d(); + Czgebs2d(*ConTxt, scope, top, *m, *n, A, *lda); +} + +void zgebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Czgebr2d(); + Czgebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc); +} + +void ztrsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +double *A; +int *lda; +int *rdest; +int *cdest; +{ + void Cztrsd2d(); + Cztrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest); +} + +void ztrrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *uplo; +char *diag; +int *m; +int *n; +double *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cztrrv2d(); + Cztrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void ztrbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +double *A; +int *lda; +{ + void Cztrbs2d(); + Cztrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda); +} + +void ztrbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc) +int *ConTxt; +char *scope; +char *top; +char *uplo; +char *diag; +int *m; +int *n; +double *A; +int *lda; +int *rsrc; +int *csrc; +{ + void Cztrbr2d(); + Cztrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc); +} + +void zgsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +int *rdest; +int *cdest; +{ + void Czgsum2d(); + Czgsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest); +} + +void zgamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Czgamx2d(); + Czgamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} + +void zgamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest) +int *ConTxt; +char *scope; +char *top; +int *m; +int *n; +double *A; +int *lda; +int *rA; +int *cA; +int *ldia; +int *rdest; +int *cdest; +{ + void Czgamn2d(); + Czgamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia, + *rdest, *cdest); +} +#endif debian/compat0000644000000000000000000000000211626511222010362 0ustar 5 debian/changelog0000644000000000000000000001226411640166116011047 0ustar blacs-pvm (1.1-21) unstable; urgency=low * Bumped standards version to 3.9.2. No changes were needed. * Switch to dpkg-source 3.0 (quilt) format. * Maintainer's mail has been changed. -- Muammar El Khatib Sun, 28 Aug 2011 21:11:26 +0200 blacs-pvm (1.1-20) unstable; urgency=low * Bumped standards version to 3.8.4. No changes were needed. * debian/control: blacs-pvm-test was depending on a non existent package (blacsgf-test-common). Such an error has been corrected updating the Depends field with the name of the existent package, in this case blacs-test-common. -- Muammar El Khatib Wed, 31 Mar 2010 20:16:19 -0430 blacs-pvm (1.1-19) unstable; urgency=low * Bug: 'blacs-pvm-test depends on obsolete blacs-test-common' has been fixed in this revision. (Closes: #473740) * Copyright file has been fixed. So there is no lintian's complains about that. -- Muammar El Khatib Fri, 04 Apr 2008 00:59:29 -0430 blacs-pvm (1.1-18) unstable; urgency=low * Bumped standards version to 3.7.3 * debian/compat file was created. * Webpage was moved from blacs-pvm's description to control tag. * The package is now built using gfortran instead of g77. Thanks to Colin Tuckley for providing patches and helping.(Closes: #459589) -- Muammar El Khatib Wed, 09 Jan 2008 00:00:30 -0430 blacs-pvm (1.1-17) unstable; urgency=low * Bumped standards version to 3.7.2 * New maintainer. Closes: #335009 * Updated build dependency to debhelper >= 5. * The watch file was added. Thanks to James Westby. * The use of ${Source-Version} was dropped. * Added another space in front of Homepage in control. (Philipp Frauenfelder) -- Muammar El Khatib Sun, 3 Sep 2006 23:41:28 +0000 blacs-pvm (1.1-16) unstable; urgency=low * Bumped standards version to 3.6.1 * Changed documentation to comply with MPICH and LAM packages. -- Philipp Frauenfelder Wed, 17 Sep 2003 14:23:15 +0200 blacs-pvm (1.1-15) unstable; urgency=low * Added -ffunction-sections to F77 as well. Closes: #127227 -- Philipp Frauenfelder Sun, 13 Jan 2002 09:54:25 +0100 blacs-pvm (1.1-14) unstable; urgency=low * Moved -ffunction-sections from CCFLAGS to CC. Not all C files are compiled with CCFLAGS. Closes: #127227 -- Philipp Frauenfelder Sat, 5 Jan 2002 16:52:12 +0100 blacs-pvm (1.1-13) unstable; urgency=low * Added -ffunction-sections to CCFLAGS. Should make this package compile on hppa as well. Closes: #127227 -- Philipp Frauenfelder Tue, 1 Jan 2002 12:53:27 +0100 blacs-pvm (1.1-12) unstable; urgency=low * Typo in debian/control. Closes: #124458 -- Philipp Frauenfelder Sun, 23 Dec 2001 15:59:53 +0100 blacs-pvm (1.1-11) unstable; urgency=low * Made sure -fPIC is used for all compilations in the shared library case (was not before!). Closes: #108249 -- Philipp Frauenfelder Fri, 10 Aug 2001 11:25:51 +0000 blacs-pvm (1.1-10) unstable; urgency=low * Changed section of blacs1-pvm from devel to libs and added some more sensible depends. -- Philipp Frauenfelder Fri, 3 Aug 2001 15:42:28 +0000 blacs-pvm (1.1-9) unstable; urgency=low * Added Build-Depends to pvm-dev. Closes: #70933 -- Philipp Frauenfelder Wed, 6 Sep 2000 09:55:40 +0200 blacs-pvm (1.1-8) unstable; urgency=low * New standards version: 3.2.1 * Build-Depends. Closes: #70178 -- Philipp Frauenfelder Mon, 4 Sep 2000 15:53:30 +0200 blacs-pvm (1.1-7) frozen; urgency=low * Recompiling on potato. -- Philipp Frauenfelder Sat, 22 Apr 2000 16:42:31 +0200 blacs-pvm (1.1-6) unstable; urgency=low * Moved creation of TESTING/EXE to build targets in debian/rules. Closes: #51631. -- Philipp Frauenfelder Tue, 30 Nov 1999 16:44:18 +0100 blacs-pvm (1.1-5) unstable; urgency=low * Add TESTING/EXE directory if it does not exist in rules. -- Philipp Frauenfelder Thu, 18 Nov 1999 13:56:15 +0100 blacs-pvm (1.1-4) unstable; urgency=low * Changed build process to get shared libraries too. Inspired by Camm Maguire . New packages: blacs1-pvm, blacs-pvm-dev, blacs-test-pvm. Obsolete: blacs-pvm. -- Philipp Frauenfelder Wed, 3 Nov 1999 14:47:00 +0100 blacs-pvm (1.1-3) unstable; urgency=low * Changed priority from optional to extra to fix dependency bug. * Bumped standards version to 3.0.1. * Moved to debhelper v2. -- Philipp Frauenfelder Thu, 19 Aug 1999 11:44:36 +0200 blacs-pvm (1.1-2) unstable; urgency=low * Changed path in Bmake.inc, closes #37402 (which was against blacs-mpi but applies for blacs-pvm too) * Changed binary-arch and binary-indep in debian/rules, closes #37403 -- Philipp Frauenfelder Mon, 10 May 1999 23:52:04 +0200 blacs-pvm (1.1-1) unstable; urgency=low * Initial release. -- Philipp Frauenfelder Sat, 24 Apr 1999 11:29:51 +0200 debian/blacs1-pvm.dirs0000644000000000000000000000001011626511222012003 0ustar usr/lib debian/copyright0000644000000000000000000000536111626511222011124 0ustar This package was debianized by Philipp Frauenfelder on Sat, 24 Apr 1999 09:42:50 +0200 The current Debian maintainer is Muammar El Khatib It was downloaded from: http://www.netlib.org/blacs/ Susan Blackford : Yes, the "legal use" of the BLACS is exactly the same as for ScaLAPACK. Freely-available software. Public domain or copyright notice, quoting from: http://www.netlib.org/scalapack/faq.html 1.2) How do I reference ScaLAPACK in a scientific publication? We ask that you cite the ScaLAPACK Users' Guide. @BOOK{slug, AUTHOR = {Blackford, L. S. and Choi, J. and Cleary, A. and D'Azevedo, E. and Demmel, J. and Dhillon, I. and Dongarra, J. and Hammarling, S. and Henry, G. and Petitet, A. and Stanley, K. and Walker, D. and Whaley, R. C.}, TITLE = {{ScaLAPACK} Users' Guide}, PUBLISHER = {Society for Industrial and Applied Mathematics}, YEAR = {1997}, ADDRESS = {Philadelphia, PA}, ISBN = {0-89871-397-8 (paperback)} } 1.4) Are there legal restrictions on the use of ScaLAPACK software? ScaLAPACK (like LINPACK, EISPACK, LAPACK, etc) is a freely-available software package. It is available from netlib via anonymous ftp and the World Wide Web. It can, and is, being included in commercial packages (e.g., IBM's Parallel ESSL, NAG Numerical PVM and MPI Library). We only ask that proper credit be given to the authors. Like all software, it is copyrighted. It is not trademarked, but we do ask the following: If you modify the source for these routines we ask that you change the name of the routine and comment the changes made to the original. We will gladly answer any questions regarding the software. If a modification is done, however, it is the responsibility of the person who modified the routine to provide support. 1.5) Are there legal restrictions on the use of ScaLAPACK software? ScaLAPACK (like LINPACK, EISPACK, LAPACK, etc) is a freely-available software package. It is available from netlib via anonymous ftp and the World Wide Web. It can, and is, being included in commercial packages (e.g., Sun's S3L, IBM's Parallel ESSL, NAG Numerical PVM and Interactive Supercomputing's Star-P for MATLAB). We only ask that proper credit be given to the authors. Like all software, it is copyrighted. It is not trademarked, but we do ask the following: If you modify the source for these routines we ask that you change the name of the routine and comment the changes made to the original. We will gladly answer any questions regarding the software. If a modification is done, however, it is the responsibility of the person who modified the routine to provide support. debian/source/0000755000000000000000000000000011626511564010475 5ustar debian/source/format0000644000000000000000000000001411626511564011703 0ustar 3.0 (quilt) debian/blacs-pvm-test.dirs0000644000000000000000000000001611626511222012705 0ustar usr/lib/blacs debian/blacs1-pvm.links0000644000000000000000000000006611626511222012175 0ustar usr/lib/libblacs-pvm.so.1.1 usr/lib/libblacs-pvm.so.1 debian/blacs-pvm-dev.dirs0000644000000000000000000000001011626511222012476 0ustar usr/lib debian/control0000644000000000000000000000600211640165732010574 0ustar Source: blacs-pvm Section: devel Priority: extra Maintainer: Muammar El Khatib Standards-Version: 3.9.2 Build-Depends: debhelper (>= 5), gfortran, pvm-dev, quilt Homepage: http://www.netlib.org/blacs/ Package: blacs-pvm-dev Architecture: any Depends: blacs1-pvm (= ${binary:Version}), ${shlibs:Depends}, ${misc:Depends} Suggests: scalapack-doc Replaces: blacs-pvm Conflicts: blacs-pvm Description: Basic Linear Algebra Comm. Subprograms - Dev. files for PVM The BLACS project is an ongoing investigation whose purpose is to create a linear algebra oriented message passing interface that may be implemented efficiently and uniformly across a large range of distributed memory platforms. . You can choose between an implementation based on MPI or PVM. This package uses PVM. . There are packages for the shared libraries, for the static libraries and the development files (this one) and for test programs. . Most users do not need to install this package directly because it is used as a high level driver for the communication in the ScaLAPACK packages. Therefore, it is installed when installing ScaLAPACK. ScaLAPACK is a parallel version of LAPACK and is used on Beowulf type clusters. Package: blacs1-pvm Section: libs Architecture: any Depends: pvm, ${shlibs:Depends}, ${misc:Depends} Description: Basic Linear Algebra Comm. Subprograms - Shared libs. for PVM The BLACS project is an ongoing investigation whose purpose is to create a linear algebra oriented message passing interface that may be implemented efficiently and uniformly across a large range of distributed memory platforms. . You can choose between an implementation based on MPI or PVM. This package uses PVM. . There are packages for the shared libraries (this one), for the static libraries and the development files and for test programs. . Most users do not need to install this package directly because it is used as a high level driver for the communication in the ScaLAPACK packages. Therefore, it is installed when installing ScaLAPACK. ScaLAPACK is a parallel version of LAPACK and is used on Beowulf type clusters. Package: blacs-pvm-test Architecture: any Depends: blacs-test-common, ${shlibs:Depends}, ${misc:Depends} Description: Basic Linear Algebra Comm. Subprograms - Test files for PVM The BLACS project is an ongoing investigation whose purpose is to create a linear algebra oriented message passing interface that may be implemented efficiently and uniformly across a large range of distributed memory platforms. . You can choose between an implementation based on MPI or PVM. This package uses PVM. . There are packages for the shared libraries, for the static libraries and the development files and for test programs (this one). . Most users do not need to install this package directly because it is used as a high level driver for the communication in the ScaLAPACK packages. Therefore, it is installed when installing ScaLAPACK. ScaLAPACK is a parallel version of LAPACK and is used on Beowulf type clusters. debian/rules0000755000000000000000000000532311640165675010264 0ustar #! /usr/bin/make -f # Made with the aid of debmake, by Christoph Lameter, # based on the sample debian/rules file for GNU hello by Ian Jackson. # Handmodified by P. Frauenfelder for debhelper support, 5 Sept 1998 topdir=$(shell pwd) build: build-arch build-indep build-arch: build-stamp build-indep: build-stamp build-stamp: build-stamp-shared build-stamp-static build-stamp-test $(QUILT_STAMPFN) touch build-stamp build-stamp-shared: dh_testdir [ -d TESTING/EXE ] || mkdir TESTING/EXE # clean BASEDIR=$(topdir) make cleanall cd TESTING && make clean # build the shared libraries BASEDIR=$(topdir) FPIC=-fPIC make pvm mkdir -p tmp set -e ;\ cd tmp ;\ ar x ../LIB/blacs_PVM-LINUX-0.a ;\ mkdir tmp ;\ for j in $$(find -name "*.C") ;\ do mv $$j tmp/$$(echo $$j | sed 's,C$$,o,g') ;\ done;\ cd .. ;\ gcc -shared -Wl,-soname=libblacs-pvm.so.1 -o libblacs-pvm.so.1.1 \ $$(find tmp -name "*.o");\ ln -sf libblacs-pvm.so.1.1 libblacs-pvm.so.1 ;\ ln -sf libblacs-pvm.so.1 libblacs-pvm.so ;\ rm -f tmp/tmp/* ; rmdir tmp/tmp ; rm tmp/* ;\ rmdir tmp touch build-stamp-shared build-stamp-static: dh_testdir [ -d TESTING/EXE ] || mkdir TESTING/EXE # clean BASEDIR=$(topdir) make cleanall cd TESTING && make clean # static libaries BASEDIR=$(topdir) make pvm touch build-stamp-static build-stamp-test: dh_testdir [ -d TESTING/EXE ] || mkdir TESTING/EXE # clean BASEDIR=$(topdir) make cleanall cd TESTING && make clean # testing binaries # cd TESTING && BASEDIR=$(topdir) BTLIBS='$$(BLACSLIB) $$(PVMLIB)' make cd TESTING && BASEDIR=$(topdir) BTLIBS='-L.. -lblacs-pvm $$(PVMLIB)' make touch build-stamp-test clean: unpatch dh_testdir dh_testroot rm -f build-stamp-* BASEDIR=$(topdir) make cleanall cd LIB && rm -f *.a cd TESTING && make clean rm -f TESTING/EXE/* rm -f SRC/PVM/INTERNAL/Bconfig.h rm -f SRC/PVM/INTERNAL/Bdef.h rm -f libblacs*so* dh_clean binary-arch: build dh_testdir dh_testroot dh_clean -k dh_installdirs -a install LIB/blacs_PVM-LINUX-0.a \ `pwd`/debian/blacs-pvm-dev/usr/lib/libblacs-pvm.a install libblacs-pvm.so.1.1 \ `pwd`/debian/blacs1-pvm/usr/lib/libblacs-pvm.so.1.1 install TESTING/EXE/xFbtest_PVM-0 \ `pwd`/debian/blacs-pvm-test/usr/lib/blacs/fblacs_test-pvm install TESTING/EXE/xCbtest_PVM-0 \ `pwd`/debian/blacs-pvm-test/usr/lib/blacs/cblacs_test-pvm dh_installdocs -a README dh_installman -a dh_installchangelogs -a dh_link -a dh_compress -a dh_fixperms -a dh_strip -a dh_makeshlibs -V dh_installdeb -a dh_shlibdeps -a dh_gencontrol -a dh_md5sums -a dh_builddeb -a binary-indep: build source diff: @echo >&2 'source and diff are obsolete - use dpkg-source -b'; false binary: binary-indep binary-arch .PHONY: binary binary-arch binary-indep clean build unpatch