--- blacs-mpi-1.1.orig/BMAKES/Bmake.MPI-O2K +++ blacs-mpi-1.1/BMAKES/Bmake.MPI-O2K @@ -0,0 +1,224 @@ +#============================================================================= +#====================== 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 = $(HOME)/BLACS + +# --------------------------------------------------------------------------- +# 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 = MPI + +# ------------------------------------------------------------- +# The platform identifier to suffix to the end of library names +# ------------------------------------------------------------- + PLAT = IRIX64 + +# ---------------------------------------------------------- +# Name and location of the BLACS library. See section 2 for +# details on BLACS debug level (BLACSDBGLVL). +# ---------------------------------------------------------- + BLACSdir = $(BTOPdir)/LIB + BLACSDBGLVL = 0 + BLACSFINIT = $(BLACSdir)/blacsF77init_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + BLACSCINIT = $(BLACSdir)/blacsCinit_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + BLACSLIB = $(BLACSdir)/blacs_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + +# ------------------------------------- +# Name and location of the MPI library. +# ------------------------------------- +# MPIdir = /usr/local/mpi +# MPIdev = ch_p4 +# MPIplat = IRIX +# MPILIBdir = $(MPIdir)/lib/$(MPIplat)/$(MPIdev) +# MPIINCdir = $(MPIdir)/include + MPIINCdir = /usr/include +# MPILIB = $(MPILIBdir)/libmpi.a + MPILIB = -lmpi + +# ------------------------------------- +# All libraries required by the tester. +# ------------------------------------- + BTLIBS = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT) $(MPILIB) + +# ---------------------------------------------------------------- +# The directory to put the installation help routines' executables +# ---------------------------------------------------------------- + INSTdir = $(BTOPdir)/INSTALL/EXE + +# ------------------------------------------------ +# The name and location of the tester's executable +# ------------------------------------------------ + TESTdir = $(BTOPdir)/TESTING/EXE + FTESTexe = $(TESTdir)/xFbtest_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL) + CTESTexe = $(TESTdir)/xCbtest_$(COMMLIB)-$(PLAT)-$(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. +# NOTE: The MPI defaults have been set for MPICH. +#============================================================================= + +# ----------------------------------------------------------------------- +# The directory to find the required communication library include files, +# if they are required by your system. +# ----------------------------------------------------------------------- + SYSINC = -I$(MPIINCdir) + +# --------------------------------------------------------------------------- +# 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_ + +# ------------------------------------------------------------------------ +# Allows the user to vary the topologies that the BLACS default topologies +# (TOP = ' ') correspond to. If you wish to use a particular topology +# (as opposed to letting the BLACS make the choice), uncomment the +# following macros, and replace the character in single quotes with the +# topology of your choice. +# ------------------------------------------------------------------------ +# DEFBSTOP = -DDefBSTop="'1'" +# DEFCOMBTOP = -DDefCombTop="'1'" + +# ------------------------------------------------------------------- +# If your MPI_Send is locally-blocking, substitute the following line +# for the empty macro definition below. +# SENDIS = -DSndIsLocBlk +# ------------------------------------------------------------------- + SENDIS = + +# -------------------------------------------------------------------- +# If your MPI handles packing of non-contiguous messages by copying to +# another buffer or sending extra bytes, better performance may be +# obtained by replacing the empty macro definition below with the +# macro definition on the following line. +# BUFF = -DNoMpiBuff +# -------------------------------------------------------------------- + BUFF = + +# ----------------------------------------------------------------------- +# If you know something about your system, you may make it easier for the +# BLACS to translate between C and fortran communicators. If the empty +# macro defininition is left alone, this translation will cause the C +# BLACS to globally block for MPI_COMM_WORLD on calls to BLACS_GRIDINIT +# and BLACS_GRIDMAP. If you choose one of the options for translating +# the context, neither the C or fortran calls will globally block. +# If you are using MPICH, or a derivitive system, you can replace the +# empty macro definition below with the following (note that if you let +# MPICH do the translation between C and fortran, you must also indicate +# here if your system has pointers that are longer than integers. If so, +# define -DPOINTER_64_BITS=1.) For help on setting TRANSCOMM, you can +# run BLACS/INSTALL/xtc_CsameF77 and BLACS/INSTALL/xtc_UseMpich as +# explained in BLACS/INSTALL/README. +# TRANSCOMM = -DUseMpich -DPOINTER_64_BITS=1 +# +# If you know that your MPI uses the same handles for fortran and C +# communicators, you can replace the empty macro definition below with +# the macro definition on the following line. + TRANSCOMM = -DCSameF77 +# ----------------------------------------------------------------------- +# TRANSCOMM = + +# -------------------------------------------------------------------------- +# You may choose to have the BLACS internally call either the C or Fortran77 +# interface to MPI by varying the following macro. If TRANSCOMM is left +# empty, the C interface BLACS_GRIDMAP/BLACS_GRIDINIT will globally-block if +# you choose to use the fortran internals, and the fortran interface will +# block if you choose to use the C internals. It is recommended that the +# user leave this macro definition blank, unless there is a strong reason +# to prefer one MPI interface over the other. +# WHATMPI = -DUseF77Mpi +# WHATMPI = -DUseCMpi +# -------------------------------------------------------------------------- + WHATMPI = + +# --------------------------------------------------------------------------- +# Some early versions of MPICH and its derivatives cannot handle user defined +# zero byte data types. If your system has this problem (compile and run +# BLACS/INSTALL/xsyserrors to check if unsure), replace the empty macro +# definition below with the macro definition on the following line. +# SYSERRORS = -DZeroByteTypeBug +# --------------------------------------------------------------------------- + SYSERRORS = + +# ------------------------------------------------------------------ +# 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) $(SENDIS) $(BUFF) $(TRANSCOMM) $(WHATMPI) $(SYSERRORS) +#============================================================================= +#=============================== 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 = f77 + F77NO_OPTFLAGS = -64 -mips4 -r10000 +# F77NO_OPTFLAGS = -n32 -mips4 -r10000 + F77FLAGS = $(F77NO_OPTFLAGS) -O2 + F77LOADER = $(F77) + F77LOADFLAGS = $(F77FLAGS) + CC = cc + CCFLAGS = -O2 -64 -mips4 -r10000 +# CCFLAGS = -O2 -n32 -mips4 -r10000 + CCLOADER = $(CC) + CCLOADFLAGS = $(CCFLAGS) + +# -------------------------------------------------------------------------- +# 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 = echo + +#============================================================================= +#=============================== End SECTION 3 =============================== +#============================================================================= --- blacs-mpi-1.1.orig/BMAKES/Bmake.MPI-SPP +++ blacs-mpi-1.1/BMAKES/Bmake.MPI-SPP @@ -0,0 +1,220 @@ +#============================================================================= +#====================== 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 = $(HOME)/BLACS + +# --------------------------------------------------------------------------- +# 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 = MPI + +# ------------------------------------------------------------- +# The platform identifier to suffix to the end of library names +# ------------------------------------------------------------- + PLAT = SPP + +# ---------------------------------------------------------- +# Name and location of the BLACS library. See section 2 for +# details on BLACS debug level (BLACSDBGLVL). +# ---------------------------------------------------------- + BLACSdir = $(BTOPdir)/LIB + BLACSDBGLVL = 0 + BLACSFINIT = $(BLACSdir)/blacsF77init_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + BLACSCINIT = $(BLACSdir)/blacsCinit_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + BLACSLIB = $(BLACSdir)/blacs_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + +# ------------------------------------- +# Name and location of the MPI library. +# ------------------------------------- + MPIdir = /opt/mpi_1.3.2 + MPIINCdir = $(MPIdir)/include + MPILIB = + +# ------------------------------------- +# All libraries required by the tester. +# ------------------------------------- + BTLIBS = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT) $(MPILIB) + +# ---------------------------------------------------------------- +# The directory to put the installation help routines' executables +# ---------------------------------------------------------------- + INSTdir = $(BTOPdir)/INSTALL/EXE + +# ------------------------------------------------ +# The name and location of the tester's executable +# ------------------------------------------------ + TESTdir = $(BTOPdir)/TESTING/EXE + FTESTexe = $(TESTdir)/xFbtest_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL) + CTESTexe = $(TESTdir)/xCbtest_$(COMMLIB)-$(PLAT)-$(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. +# NOTE: The MPI defaults have been set for MPICH. +#============================================================================= + +# ----------------------------------------------------------------------- +# The directory to find the required communication library include files, +# if they are required by your system. +# ----------------------------------------------------------------------- + SYSINC = -I$(MPIINCdir) + +# --------------------------------------------------------------------------- +# 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 = -DNoChange + +# ------------------------------------------------------------------------ +# Allows the user to vary the topologies that the BLACS default topologies +# (TOP = ' ') correspond to. If you wish to use a particular topology +# (as opposed to letting the BLACS make the choice), uncomment the +# following macros, and replace the character in single quotes with the +# topology of your choice. +# ------------------------------------------------------------------------ +# DEFBSTOP = -DDefBSTop="'1'" +# DEFBSTOP = -DDefBSTop=49 +# DEFCOMBTOP = -DDefCombTop="'1'" +# DEFCOMBTOP = -DDefCombTop=49 + +# ------------------------------------------------------------------- +# If your MPI_Send is locally-blocking, substitute the following line +# for the empty macro definition below. +# SENDIS = -DSndIsLocBlk +# ------------------------------------------------------------------- + SENDIS = + +# -------------------------------------------------------------------- +# If your MPI handles packing of non-contiguous messages by copying to +# another buffer or sending extra bytes, better performance may be +# obtained by replacing the empty macro definition below with the +# macro definition on the following line. +# BUFF = -DNoMpiBuff +# -------------------------------------------------------------------- + BUFF = + +# ----------------------------------------------------------------------- +# If you know something about your system, you may make it easier for the +# BLACS to translate between C and fortran communicators. If the empty +# macro defininition is left alone, this translation will cause the C +# BLACS to globally block for MPI_COMM_WORLD on calls to BLACS_GRIDINIT +# and BLACS_GRIDMAP. If you choose one of the options for translating +# the context, neither the C or fortran calls will globally block. +# If you are using MPICH, or a derivitive system, you can replace the +# empty macro definition below with the following (note that if you let +# MPICH do the translation between C and fortran, you must also indicate +# here if your system has pointers that are longer than integers. If so, +# define -DPOINTER_64_BITS=1.) For help on setting TRANSCOMM, you can +# run BLACS/INSTALL/xtc_CsameF77 and BLACS/INSTALL/xtc_UseMpich as +# explained in BLACS/INSTALL/README. +# TRANSCOMM = -DUseMpich +# +# If you know that your MPI uses the same handles for fortran and C +# communicators, you can replace the empty macro definition below with +# the macro definition on the following line. +# TRANSCOMM = -DCSameF77 +# ----------------------------------------------------------------------- +# TRANSCOMM = + TRANSCOMM = -DUseMpi2 + +# -------------------------------------------------------------------------- +# You may choose to have the BLACS internally call either the C or Fortran77 +# interface to MPI by varying the following macro. If TRANSCOMM is left +# empty, the C interface BLACS_GRIDMAP/BLACS_GRIDINIT will globally-block if +# you choose to use the fortran internals, and the fortran interface will +# block if you choose to use the C internals. It is recommended that the +# user leave this macro definition blank, unless there is a strong reason +# to prefer one MPI interface over the other. +# WHATMPI = -DUseF77Mpi +# WHATMPI = -DUseCMpi +# -------------------------------------------------------------------------- + WHATMPI = + +# --------------------------------------------------------------------------- +# Some early versions of MPICH and its derivatives cannot handle user defined +# zero byte data types. If your system has this problem (compile and run +# BLACS/INSTALL/xsyserrors to check if unsure), replace the empty macro +# definition below with the macro definition on the following line. + SYSERRORS = -DZeroByteTypeBug +# --------------------------------------------------------------------------- +# SYSERRORS = + +# ------------------------------------------------------------------ +# 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) $(SENDIS) $(BUFF) $(TRANSCOMM) $(WHATMPI) $(SYSERRORS) +#============================================================================= +#=============================== 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 = mpif77 + F77NO_OPTFLAGS = + F77FLAGS = $(F77NO_OPTFLAGS) -O + F77LOADER = $(F77) + F77LOADFLAGS = -Wl, + CC = mpicc + CCFLAGS = -O -Aa + CCLOADER = $(CC) + CCLOADFLAGS = -Wl, + +# -------------------------------------------------------------------------- +# 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 = echo + +#============================================================================= +#=============================== End SECTION 3 =============================== +#============================================================================= --- blacs-mpi-1.1.orig/BMAKES/Bmake.MPI-T3E +++ blacs-mpi-1.1/BMAKES/Bmake.MPI-T3E @@ -5,11 +5,6 @@ # the BLACS and its tester. #============================================================================= -# -------------------------------------- -# Make sure we've got a consistent shell -# -------------------------------------- - SHELL = /bin/sh - # ----------------------------- # The top level BLACS directory # ----------------------------- @@ -44,9 +39,11 @@ BLACSCINIT = $(BLACSdir)/blacsCinit_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a BLACSLIB = $(BLACSdir)/blacs_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a -# ------------------------------------- -# Name and location of the MPI library. -# ------------------------------------- +# ------------------------------------------------------------------------- +# Name and location of the MPI library. Note that you need mpt1.2.0.0.6 or +# newer to run on the T3E. +# ------------------------------------------------------------------------- +# MPIdir = /opt/ctl/mpt/1.2.0.0.6 MPIdir = /opt/ctl/mpt/mpt MPILIBdir = $(MPIdir) MPIINCdir = $(MPIdir)/include @@ -72,7 +69,8 @@ # The name and location of the tester's executable # ------------------------------------------------ TESTdir = $(BTOPdir)/TESTING/EXE - TESTexe = $(TESTdir)/x$(BTINTFACE)btest_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL) + FTESTexe = $(TESTdir)/xFbtest_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL) + CTESTexe = $(TESTdir)/xCbtest_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL) #============================================================================= #=============================== End SECTION 1 =============================== #============================================================================= @@ -112,9 +110,9 @@ # ------------------------------------------------------------------- # If your MPI_Send is locally-blocking, substitute the following line # for the empty macro definition below. - SENDIS = -DSndIsLocBlk +# SENDIS = -DSndIsLocBlk # ------------------------------------------------------------------- -# SENDIS = + SENDIS = # -------------------------------------------------------------------- # If your MPI handles packing of non-contiguous messages by copying to @@ -165,7 +163,8 @@ # below with the empty macro definition on the following line. # SYSERRORS = # --------------------------------------------------------------------------- - SYSERRORS = -DZeroByteTypeBug +# SYSERRORS = -DZeroByteTypeBug + SYSERRORS = -DT3EReductErr -DT3ETrError # ------------------------------------------------------------------ # These macros set the debug level for the BLACS. The fastest @@ -198,7 +197,7 @@ # macros should be obvious from the names. #============================================================================= F77 = f90 - F77NO_OPTFLAGS = -dp + F77NO_OPTFLAGS = -dp -X m F77FLAGS = $(F77NO_OPTFLAGS) -O3,aggress F77LOADER = $(F77) F77LOADFLAGS = --- blacs-mpi-1.1.orig/Bmake.inc +++ blacs-mpi-1.1/Bmake.inc @@ -0,0 +1,240 @@ +#============================================================================= +#====================== 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 = MPI + +# ------------------------------------------------------------- +# The platform identifier to suffix to the end of library names +# ------------------------------------------------------------- + PLAT = LINUX + +# ---------------------------------------------------------- +# Name and location of the BLACS library. See section 2 for +# details on BLACS debug level (BLACSDBGLVL). +# ---------------------------------------------------------- + BLACSdir = $(BTOPdir)/LIB + BLACSDBGLVL = 0 + BLACSFINIT = $(BLACSdir)/blacsF77init_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + BLACSCINIT = $(BLACSdir)/blacsCinit_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + BLACSLIB = $(BLACSdir)/blacs_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + +# ------------------------------------- +# Name and location of the MPI library. +# ------------------------------------- +ifeq ($(MPI),mpich) +# for compilation with mpich: + MPIdir = /usr/lib/mpich + MPIdev = ch_p4 + MPIplat = LINUX + MPILIBdir = $(MPIdir)/lib + MPIINCdir = $(MPIdir)/include + MPILIB = $(MPILIBdir)/shared/libmpich.so $(MPILIBdir)/shared/libpmpich.so $(MPILIBdir)/libmpich.a +else +# for compilation with lam: + MPILIBdir = /usr/lib/lam/lib + MPIINCdir = /usr/include/lam + MPILIB = -L/usr/lib/lam/lib -llam +endif + + +# ------------------------------------- +# All libraries required by the tester. +# ------------------------------------- +# BTLIBS = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT) $(MPILIB) +# BTLIBS = -L.. -lblacsF77init -lblacs -lblacsF77init -lmpi + +# ---------------------------------------------------------------- +# The directory to put the installation help routines' executables +# ---------------------------------------------------------------- + INSTdir = $(BTOPdir)/INSTALL/EXE + +# ------------------------------------------------ +# The name and location of the tester's executable +# ------------------------------------------------ + TESTdir = $(BTOPdir)/TESTING/EXE + FTESTexe = $(TESTdir)/xFbtest_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL)-$(BUILD)-$(MPI) + CTESTexe = $(TESTdir)/xCbtest_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL)-$(BUILD)-$(MPI) +#============================================================================= +#=============================== 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. +# NOTE: The MPI defaults have been set for MPICH. +#============================================================================= + +# ----------------------------------------------------------------------- +# The directory to find the required communication library include files, +# if they are required by your system. +# ----------------------------------------------------------------------- +ifeq ($(MPI),mpich) + SYSINC = -I$(MPIINCdir) -I$(MPIdir)/build/$(MPIplat)/$(MPIdev)/include +else + SYSINC = -I$(MPIINCdir) +endif + +# --------------------------------------------------------------------------- +# 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_ +# INTFACE = -DAdd_ + +# ------------------------------------------------------------------------ +# Allows the user to vary the topologies that the BLACS default topologies +# (TOP = ' ') correspond to. If you wish to use a particular topology +# (as opposed to letting the BLACS make the choice), uncomment the +# following macros, and replace the character in single quotes with the +# topology of your choice. +# ------------------------------------------------------------------------ +# DEFBSTOP = -DDefBSTop="'1'" +# DEFCOMBTOP = -DDefCombTop="'1'" + +# ------------------------------------------------------------------- +# If your MPI_Send is locally-blocking, substitute the following line +# for the empty macro definition below. +# SENDIS = -DSndIsLocBlk +# ------------------------------------------------------------------- + SENDIS = + +# -------------------------------------------------------------------- +# If your MPI handles packing of non-contiguous messages by copying to +# another buffer or sending extra bytes, better performance may be +# obtained by replacing the empty macro definition below with the +# macro definition on the following line. +# BUFF = -DNoMpiBuff +# -------------------------------------------------------------------- + BUFF = + +# ----------------------------------------------------------------------- +# If you know something about your system, you may make it easier for the +# BLACS to translate between C and fortran communicators. If the empty +# macro defininition is left alone, this translation will cause the C +# BLACS to globally block for MPI_COMM_WORLD on calls to BLACS_GRIDINIT +# and BLACS_GRIDMAP. If you choose one of the options for translating +# the context, neither the C or fortran calls will globally block. +# If you are using MPICH, or a derivitive system, you can replace the +# empty macro definition below with the following (note that if you let +# MPICH do the translation between C and fortran, you must also indicate +# here if your system has pointers that are longer than integers. If so, +# define -DPOINTER_64_BITS=1.) For help on setting TRANSCOMM, you can +# run BLACS/INSTALL/xtc_CsameF77 and BLACS/INSTALL/xtc_UseMpich as +# explained in BLACS/INSTALL/README. +ifeq ($(MPI),mpich) + TRANSCOMM = -DUseMpich +endif + +# If you know that your MPI uses the same handles for fortran and C +# communicators, you can replace the empty macro definition below with +# the macro definition on the following line. +# TRANSCOMM = -DCSameF77 +# ----------------------------------------------------------------------- +# TRANSCOMM = +ifeq ($(MPI),lam) + TRANSCOMM = -DUseMpi2 +endif + +# -------------------------------------------------------------------------- +# You may choose to have the BLACS internally call either the C or Fortran77 +# interface to MPI by varying the following macro. If TRANSCOMM is left +# empty, the C interface BLACS_GRIDMAP/BLACS_GRIDINIT will globally-block if +# you choose to use the fortran internals, and the fortran interface will +# block if you choose to use the C internals. It is recommended that the +# user leave this macro definition blank, unless there is a strong reason +# to prefer one MPI interface over the other. +# WHATMPI = -DUseF77Mpi +# WHATMPI = -DUseCMpi +# -------------------------------------------------------------------------- + WHATMPI = + +# --------------------------------------------------------------------------- +# Some early versions of MPICH and its derivatives cannot handle user defined +# zero byte data types. If your system has this problem (compile and run +# BLACS/INSTALL/xsyserrors to check if unsure), replace the empty macro +# definition below with the macro definition on the following line. +# SYSERRORS = -DZeroByteTypeBug +# --------------------------------------------------------------------------- + SYSERRORS = + +# ------------------------------------------------------------------ +# 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) $(SENDIS) $(BUFF) $(TRANSCOMM) $(WHATMPI) $(SYSERRORS) +#============================================================================= +#=============================== 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 + F77NO_OPTFLAGS = $(FPIC) -w + F77FLAGS = $(F77NO_OPTFLAGS) -O4 + F77LOADER = $(F77) + F77LOADFLAGS = + CC = cc + CCFLAGS = $(FPIC) -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 =============================== +#============================================================================= --- blacs-mpi-1.1.orig/Makefile +++ blacs-mpi-1.1/Makefile @@ -12,11 +12,7 @@ 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 ) + ( cd SRC/MPI ; make clean ) testing: tester xbtest : tester --- blacs-mpi-1.1.orig/SRC/MPI/Bconfig.h +++ blacs-mpi-1.1/SRC/MPI/Bconfig.h @@ -95,6 +95,11 @@ #define USEMPICH 1 #define CSAMEF77 2 #define BONEHEAD 3 +#define USEMPI2 4 + +#ifdef UseMpi2 +#define BI_TransComm USEMPI2 +#endif #ifdef UseMpich #define BI_TransComm USEMPICH --- blacs-mpi-1.1.orig/SRC/MPI/Bdef.h +++ blacs-mpi-1.1/SRC/MPI/Bdef.h @@ -6,6 +6,10 @@ * Include the system dependant and user defined stuff */ #include "Bconfig.h" +#ifdef CRAY +#define float double +#include +#endif /* * ======================================================================== * TYPEDEF'S USED IN THE BLACS @@ -430,10 +434,6 @@ #define F_VOID_FUNC void #define F_INT_FUNC int #define F_DOUBLE_FUNC double -#ifdef CRAY -#define float double -#include -#endif #if (INTFACE == C_CALL) @@ -647,9 +647,11 @@ #define mpi_waitall_ mpi_waitall #define mpi_wtime_ mpi_wtime #define bi_f77_get_constants_ bi_f77_get_constants +#define bi_f77_init_ bi_f77_init #else #define mpi_init_ mpi_init #define bi_f77_get_constants_ bi_f77_get_constants +#define bi_f77_init_ bi_f77_init #if (BI_TransComm == BONEHEAD) #define mpi_comm_group_ mpi_comm_group #define mpi_group_translate_ranks_ mpi_group_translate_ranks @@ -796,8 +798,10 @@ #define mpi_waitall_ MPI_WAITALL #define mpi_wtime_ MPI_WTIME #define bi_f77_get_constants_ BI_F77_GET_CONSTANTS +#define bi_f77_init_ BI_F77_INIT #else #define mpi_init_ MPI_INIT +#define bi_f77_init_ BI_F77_INIT #define bi_f77_get_constants_ BI_F77_GET_CONSTANTS #if (BI_TransComm == BONEHEAD) #define mpi_comm_group_ MPI_COMM_GROUP @@ -881,6 +885,7 @@ #define mpi_type_vector_ mpi_type_vector__ #define bi_f77_get_constants_ bi_f77_get_constants__ +#define bi_f77_init_ bi_f77_init__ #define mpi_group_translate_ranks_ mpi_group_translate_ranks__ #define bi_f77_mpi_initialized_ bi_f77_mpi_initialized__ #define bi_f77_mpi_test_ bi_f77_mpi_test__ @@ -891,6 +896,7 @@ #else #define mpi_init_ mpi_init__ #define bi_f77_get_constants_ bi_f77_get_constants__ +#define bi_f77_init_ bi_f77_init__ #if (BI_TransComm == BONEHEAD) #define mpi_comm_group_ mpi_comm_group__ #define mpi_group_translate_ranks_ mpi_group_translate_ranks__ --- blacs-mpi-1.1.orig/SRC/MPI/Bdef.h.flc +++ blacs-mpi-1.1/SRC/MPI/Bdef.h.flc @@ -0,0 +1,3 @@ + +(fast-lock-cache-data 3 (quote (13149 . 13449)) (quote nil) (quote nil) (quote (t ("^\\(\\sw+\\)[ ]*(" (1 font-lock-function-name-face)) ("^#[ ]*error[ ]+\\(.+\\)" (1 font-lock-warning-face prepend)) ("^#[ ]*\\(import\\|include\\)[ ]*\\(<[^>\" +]*>?\\)" (2 font-lock-string-face)) ("^#[ ]*define[ ]+\\(\\sw+\\)(" (1 font-lock-function-name-face)) ("^#[ ]*\\(elif\\|if\\)\\>" ("\\<\\(defined\\)\\>[ ]*(?\\(\\sw+\\)?" nil nil (1 font-lock-builtin-face) (2 font-lock-variable-name-face nil t))) ("^#[ ]*\\(\\sw+\\)\\>[ !]*\\(\\sw+\\)?" (1 font-lock-builtin-face) (2 font-lock-variable-name-face nil t)) ("\\<\\(auto\\|c\\(har\\|onst\\)\\|double\\|e\\(num\\|xtern\\)\\|float\\|int\\|long\\|register\\|s\\(hort\\|igned\\|t\\(atic\\|ruct\\)\\)\\|typedef\\|un\\(ion\\|signed\\)\\|vo\\(id\\|latile\\)\\|FILE\\|\\sw+_t\\)\\>" (0 font-lock-type-face)) ("\\<\\(break\\|continue\\|do\\|else\\|for\\|if\\|return\\|s\\(izeof\\|witch\\)\\|while\\)\\>" (0 font-lock-keyword-face)) ("\\<\\(case\\|goto\\)\\>[ ]*\\(-?\\sw+\\)?" (1 font-lock-keyword-face) (2 font-lock-constant-face nil t)) (":" ("^[ ]*\\(\\sw+\\)[ ]*:" (beginning-of-line) (end-of-line) (1 font-lock-constant-face))) ("\\<\\(auto\\|c\\(har\\|onst\\)\\|double\\|e\\(num\\|xtern\\)\\|float\\|int\\|long\\|register\\|s\\(hort\\|igned\\|t\\(atic\\|ruct\\)\\)\\|typedef\\|un\\(ion\\|signed\\)\\|vo\\(id\\|latile\\)\\|FILE\\|\\sw+_t\\)\\>\\([ *&]+\\sw+\\>\\)*" (font-lock-match-c-style-declaration-item-and-skip-to-next (goto-char (or (match-beginning 8) (match-end 1))) (goto-char (match-end 1)) (1 (if (match-beginning 2) font-lock-function-name-face font-lock-variable-name-face)))) ("\\(}\\)[ *]*\\sw" (font-lock-match-c-style-declaration-item-and-skip-to-next (goto-char (match-end 1)) nil (1 (if (match-beginning 2) font-lock-function-name-face font-lock-variable-name-face)))) ("^\\(\\sw+\\)\\>\\([ *]+\\sw+\\>\\)*" (1 font-lock-type-face) (font-lock-match-c-style-declaration-item-and-skip-to-next (goto-char (or (match-beginning 2) (match-end 1))) nil (1 (if (match-beginning 2) font-lock-function-name-face font-lock-variable-name-face)))))) (quote ((font-lock-keyword-face 49928 49930 49709 49711 13220 13224 13071 13073 13048 13052 13009 13011 11422 11424 10980 10982 10975 10979 10814 10816 10510 10512) (font-lock-function-name-face 52969 52983 52777 52791 52467 52480 52180 52193 51884 51902 51611 51629 51319 51337 51054 51072 50756 50775 50483 50502 50294 50310 50131 50147 49887 49903 49668 49684 49259 49281 49032 49054 48845 48863 48676 48694 48451 48465 48236 48250 48042 48053 47858 47869 47440 47455 47049 47064 46805 46816 46559 46570 46312 46324 46062 46074 45770 45783 45500 45513 45218 45229 44958 44969 44723 44739 44503 44519 44203 44214 43926 43937 43757 43771 43606 43620 43393 43409 43190 43206 42977 42989 42785 42797 42574 42586 42385 42397 42200 42218 42026 42044 41870 41881 41447 41475 41152 41180 40924 40941 40712 40729 40534 40551 40372 40389 40157 40173 39959 39975 39797 39812 39655 39670 39440 39458 39242 39260 39006 39023 38785 38802 38590 38606 38412 38428 38217 38233 38039 38055 37843 37860 37664 37681 37485 37501 37324 37340 37126 37141 36945 36960 36720 36738 36511 36529 36276 36288 36055 36067 35882 35896 35726 35740 35498 35513 35244 35259 34832 34848 34568 34584 34379 34391 34207 34219 30488 30492 13776 13786 13660 13670 13546 13556 13432 13442 12968 12974 12809 12813 12764 12768 12651 12660 12621 12626 12550 12559 12523 12528 12266 12279 12191 12204 12141 12154 11596 11605 11373 11382 11179 11189 10710 10720 10470 10478 10351 10358 10283 10289 10190 10198 10066 10073 9526 9535 9413 9421 8972 8984 8953 8964 8932 8944 8887 8899 8819 8830 8749 8761) (font-lock-type-face 35350 35353 33733 33736 33727 33730 33721 33724 33715 33718 33709 33712 33703 33706 33654 33657 33648 33651 33610 33613 33604 33607 33598 33601 33592 33595 33586 33589 33548 33551 33542 33545 33536 33539 33499 33502 33493 33496 33487 33490 33449 33452 33443 33446 33406 33409 33400 33403 33394 33397 33388 33391 31824 31828 31790 31793 31784 31787 31778 31781 31772 31775 31737 31740 31731 31734 31725 31728 31719 31722 31712 31716 31706 31709 31700 31703 31693 31697 31659 31662 31653 31656 31647 31650 31641 31644 31635 31638 31629 31632 31590 31593 31584 31587 31578 31581 31572 31575 31566 31569 31560 31563 31521 31524 31515 31518 31509 31512 31503 31506 31497 31500 31491 31494 31451 31454 31445 31448 31408 31411 31402 31405 31396 31399 31390 31393 31347 31350 31341 31344 31302 31305 31296 31299 31290 31293 31284 31287 31278 31281 31236 31239 31230 31233 31224 31227 31218 31221 31179 31182 31173 31176 31167 31170 31161 31164 31155 31158 31120 31123 31114 31117 31107 31111 31101 31104 31095 31098 31089 31092 31083 31086 31076 31080 31040 31043 31034 31037 31028 31031 31022 31025 31016 31019 31010 31013 31003 31007 30971 30974 30965 30968 30959 30962 30953 30956 30947 30950 30941 30944 30934 30938 30901 30904 30895 30898 30889 30892 30883 30886 30877 30880 30871 30874 30864 30868 30857 30861 30823 30826 30817 30820 30811 30814 30805 30808 30799 30802 30793 30796 30787 30790 30779 30783 30747 30750 30741 30744 30735 30738 30729 30732 30723 30726 30686 30689 30680 30683 30674 30677 30668 30671 30661 30665 30655 30658 30649 30652 30642 30646 30610 30613 30604 30607 30569 30572 30563 30566 30557 30560 30513 30516 30507 30510 30500 30504 30493 30497 30483 30487 30439 30442 30433 30436 30427 30430 30421 30424 30415 30418 30409 30412 30403 30406 30396 30400 30363 30366 30357 30360 30351 30354 30345 30348 30339 30342 30333 30336 30327 30330 30320 30324 30287 30290 30281 30284 30235 30238 30203 30206 30197 30200 30159 30162 30153 30156 30147 30150 30141 30144 30135 30138 30097 30100 30091 30094 30085 30088 30079 30082 30042 30045 30006 30009 30000 30003 29994 29997 29955 29958 29949 29952 29943 29946 29937 29940 29931 29934 29893 29896 29887 29890 29881 29884 29844 29847 29838 29841 29832 29835 29795 29798 29789 29792 29783 29786 29745 29748 29739 29742 29702 29705 29696 29699 29690 29693 29654 29657 29648 29651 29642 29645 29636 29639 29597 29600 29591 29594 29585 29588 29579 29582 29573 29576 29566 29570 29533 29536 29527 29530 29492 29495 29486 29489 29480 29483 29474 29477 29468 29471 29425 29428 29419 29422 29413 29416 29407 29410 29401 29404 29394 29398 29387 29391 29350 29353 29344 29347 29338 29341 13866 13872 13841 13847 13750 13756 13725 13731 13635 13640 13611 13616 13521 13526 13497 13502 12308 12312 12072 12078 12039 12045 12013 12016 11988 11992 11721 11724 11714 11720 11215 11221 10793 10796 10786 10792 10746 10752 9160 9164 9135 9139 8968 8971 8948 8952 8927 8931 8883 8886 8865 8869 8853 8857 8843 8846 8831 8834 8814 8818 8796 8800 8784 8788 8774 8777 8762 8765 8744 8748 7206 7211 7197 7205 5685 5688 3475 3479 3467 3474 3447 3451 3439 3446 3415 3418 3410 3413 3378 3382 3370 3377 3361 3365 3353 3357 3348 3351 3331 3335 3323 3330 3102 3105 2899 2902 2840 2843 2790 2794 2769 2775 2743 2749 2735 2742 2619 2622 2612 2618 2547 2553 2487 2490 2480 2486 2121 2126 2113 2119 2105 2112 2081 2087 2073 2079 2065 2072 1887 1890 1808 1811 1734 1737 1658 1661 1626 1629 1379 1385 1345 1351 1337 1344 1268 1271 1240 1243 1196 1202 1166 1172 1158 1165 846 849 818 821 790 793 762 765 734 737 706 709 678 681) (font-lock-string-face 53099 53112 52909 52922 52699 52711 52408 52420 52097 52114 51820 51837 51528 51545 51255 51272 50970 50988 50691 50709 50394 50409 50232 50247 50036 50051 49818 49833 49415 49436 49191 49212 48949 48966 48781 48798 48597 48610 48391 48404 48160 48170 47985 47995 47778 47792 47379 47393 46973 46983 46748 46758 46482 46493 46254 46265 45984 45996 45711 45723 45424 45434 45161 45171 44877 44892 44661 44676 44427 44437 44146 44156 43847 43860 43697 43710 43525 43540 43331 43346 42302 42319 42136 42153 41957 41967 41675 41702 41373 41400 41070 41086 40861 40877 40630 40646 40471 40487 40291 40306 40095 40110 39879 39893 39736 39750 39572 39589 39376 39393 39160 39176 38943 38959 38704 38719 38528 38543 38331 38346 38155 38170 37957 37973 37780 37796 37583 37598 37423 37438 37244 37258 37065 37079 36862 36879 36656 36673 36434 36445 36218 36229 35976 35989 35822 35835 35646 35660 35437 35451 35038 35053 34770 34785 34491 34502 34321 34332 13024 13027 12088 12099 11754 11780 11531 11559 11060 11088 10910 10938 143 154) (font-lock-comment-face 49477 49618 41743 41861 35094 35218 34018 34180 33195 33300 29037 29277 26274 26356 26084 26115 25896 25926 25633 25666 25385 25632 22753 22835 21226 21266 20138 20164 19833 20137 17201 17283 15674 15714 14586 14612 14280 14584 13910 14242 13357 13423 12902 12959 12713 12755 12331 12490 11816 11967 11643 11687 11302 11341 10608 10677 10412 10461 9745 10057 9470 9517 9173 9403 8996 9104 8611 8727 8288 8329 8168 8191 8138 8166 7993 8013 7957 7991 7891 7932 7822 7866 7776 7797 7727 7774 7619 7665 7553 7593 7475 7527 7416 7449 7305 7348 7106 7159 7029 7051 6861 6892 6775 6811 6638 6670 6324 6355 6235 6283 6101 6130 5871 5894 5738 5864 5594 5647 5508 5530 5283 5314 5198 5234 5036 5068 4556 4587 4317 4365 4160 4189 3883 3906 3708 3864 3502 3707 3248 3306 3199 3243 3126 3171 3073 3098 3002 3045 2923 2974 2864 2895 2814 2836 2663 2734 2145 2439 1969 2064 1915 1964 1836 1883 1769 1804 1693 1730 1518 1548 1439 1479 1284 1336 1107 1157 366 635 155 364 72 133 33 70) (font-lock-variable-name-face 53306 53318 53285 53297 53267 53276 53254 53258 53216 53228 53178 53190 53160 53169 52759 52768 52162 52171 51593 51602 51036 51045 50465 50474 50113 50122 49650 49659 49626 49641 49014 49023 48658 48667 48218 48227 47840 47849 47031 47040 46541 46550 46044 46053 45482 45491 44940 44949 44485 44494 43908 43917 43588 43597 43172 43181 42767 42776 42367 42376 42008 42017 41134 41143 40694 40703 40354 40363 39941 39950 39637 39646 39224 39233 38767 38776 38394 38403 38021 38030 37646 37655 37306 37315 36927 36936 36493 36502 36037 36046 35708 35717 35226 35235 34550 34559 34189 34198 33347 33355 29303 29311 29285 29294 28958 28984 28905 28920 28815 28836 28768 28777 28700 28721 28639 28659 28578 28597 28521 28537 28457 28480 28390 28416 28328 28349 28270 28286 28213 28229 28155 28172 28100 28114 28039 28059 27982 27998 27927 27941 27874 27886 27818 27833 27762 27777 27707 27721 27650 27666 27594 27609 27539 27553 27484 27498 27428 27443 27373 27387 27319 27332 27262 27278 27210 27220 27157 27169 27105 27116 27051 27064 27001 27010 26950 26960 26898 26909 26848 26857 26797 26807 26747 26756 26696 26706 26642 26655 26592 26601 26541 26551 26488 26500 26433 26447 26382 26392 26364 26373 26241 26255 26202 26215 26165 26176 26124 26139 26055 26066 26017 26029 25976 25991 25935 25950 25864 25878 25823 25838 25787 25797 25751 25761 25713 25725 25675 25687 25279 25305 25228 25243 25139 25160 25093 25102 25027 25048 24978 24988 24927 24939 24877 24888 24822 24838 24767 24783 24711 24728 24658 24672 24599 24619 24544 24560 24486 24505 24431 24447 24379 24392 24331 24340 24282 24292 24232 24243 24184 24193 24131 24145 24083 24092 24032 24044 23972 23993 23923 23933 23874 23884 23812 23835 23764 23773 23710 23725 23656 23671 23603 23617 23551 23564 23496 23512 23442 23457 23389 23403 23336 23350 23282 23297 23229 23243 23177 23190 23122 23138 23073 23083 23022 23034 22963 22983 22910 22924 22861 22871 22843 22852 22733 22741 22706 22714 22679 22687 22652 22660 22625 22633 22598 22606 22571 22579 22544 22552 22517 22525 22490 22498 22463 22471 22436 22444 22409 22417 22382 22390 22355 22363 22328 22336 22301 22309 22274 22282 22247 22255 22220 22228 22193 22201 22166 22174 22139 22147 22112 22120 22085 22093 22058 22066 22031 22039 22004 22012 21977 21985 21950 21958 21923 21931 21896 21904 21869 21877 21842 21850 21815 21823 21788 21796 21761 21769 21734 21742 21707 21715 21680 21688 21653 21661 21626 21634 21599 21607 21572 21580 21545 21553 21518 21526 21491 21499 21464 21472 21437 21445 21410 21418 21383 21391 21356 21364 21329 21337 21302 21310 21275 21283 21180 21194 21129 21141 21079 21090 21027 21040 20977 20988 20923 20938 20873 20884 20822 20834 20768 20783 20714 20729 20669 20675 20624 20630 20577 20585 20530 20538 20477 20491 20423 20438 20374 20384 20325 20335 20275 20286 20224 20236 20173 20185 19728 19754 19676 19691 19587 19608 19541 19550 19475 19496 19426 19436 19375 19387 19325 19336 19270 19286 19215 19231 19159 19176 19106 19120 19047 19067 18992 19008 18934 18953 18879 18895 18827 18840 18779 18788 18730 18740 18680 18691 18632 18641 18579 18593 18531 18540 18480 18492 18420 18441 18371 18381 18322 18332 18260 18283 18212 18221 18158 18173 18104 18119 18051 18065 17999 18012 17944 17960 17890 17905 17837 17851 17784 17798 17730 17745 17677 17691 17625 17638 17570 17586 17521 17531 17470 17482 17411 17431 17358 17372 17309 17319 17291 17300 17181 17189 17154 17162 17127 17135 17100 17108 17073 17081 17046 17054 17019 17027 16992 17000 16965 16973 16938 16946 16911 16919 16884 16892 16857 16865 16830 16838 16803 16811 16776 16784 16749 16757 16722 16730 16695 16703 16668 16676 16641 16649 16614 16622 16587 16595 16560 16568 16533 16541 16506 16514 16479 16487 16452 16460 16425 16433 16398 16406 16371 16379 16344 16352 16317 16325 16290 16298 16263 16271 16236 16244 16209 16217 16182 16190 16155 16163 16128 16136 16101 16109 16074 16082 16047 16055 16020 16028 15993 16001 15966 15974 15939 15947 15912 15920 15885 15893 15858 15866 15831 15839 15804 15812 15777 15785 15750 15758 15723 15731 15628 15642 15577 15589 15527 15538 15475 15488 15425 15436 15371 15386 15321 15332 15270 15282 15216 15231 15162 15177 15117 15123 15072 15078 15025 15033 14978 14986 14925 14939 14871 14886 14822 14832 14773 14783 14723 14734 14672 14684 14621 14633 12682 12691 12584 12593 12296 12302 12235 12241 12178 12182 12066 12071 12053 12057 12025 12038 12001 12011 11976 11987 11725 11731 11696 11704 11237 11249 10797 10808 10768 10780 9154 9159 9129 9134 9112 9120 8871 8875 8859 8863 8847 8851 8835 8841 8802 8806 8790 8794 8778 8782 8766 8772 8735 8743 8590 8605 8562 8577 8534 8544 8506 8516 8478 8488 8450 8460 8422 8438 8394 8407 8366 8377 8338 8352 8276 8283 8257 8262 8238 8243 8219 8224 8200 8205 8123 8130 8102 8111 8082 8090 8062 8068 8042 8048 8022 8029 7941 7947 7875 7880 7806 7810 7710 7717 7674 7681 7602 7613 7536 7544 7458 7470 7396 7403 7357 7365 7285 7294 7220 7234 7168 7179 7060 7079 6991 7001 6946 6956 6901 6911 6820 6833 6731 6747 6679 6696 6599 6610 6551 6564 6503 6516 6456 6468 6411 6421 6364 6376 6292 6310 6191 6207 6139 6156 6056 6073 6005 6021 5952 5970 5903 5917 5697 5711 5656 5667 5539 5558 5451 5461 5387 5397 5323 5333 5243 5256 5141 5157 5077 5094 4979 4990 4915 4928 4851 4872 4787 4801 4723 4736 4659 4671 4596 4606 4500 4510 4437 4450 4374 4392 4261 4277 4198 4215 4104 4121 4041 4057 3978 3996 3915 3929 3872 3881 3314 3322 3106 3107 2903 2908 2844 2847 2796 2800 2776 2784 2759 2767 2624 2645 2586 2607 2570 2584 2515 2536 2492 2512 2467 2476 2448 2458 2134 2142 2130 2131 2127 2128 2095 2103 2091 2092 2088 2089 1898 1903 1891 1896 1819 1824 1812 1817 1738 1748 1662 1672 1631 1639 1587 1596 1386 1398 1365 1377 1276 1279 1272 1274 1258 1263 1251 1256 1244 1249 1203 1213 1184 1194 1070 1083 1034 1048 1003 1012 969 981 932 947 899 910 866 877 830 843 802 816 774 783 746 758 718 733 690 701 662 673 643 652 24 30 9 15) (font-lock-builtin-face 53349 53354 53341 53346 53334 53339 53299 53305 53278 53283 53260 53266 53248 53253 53240 53245 53209 53215 53203 53207 53171 53177 53154 53159 53146 53151 52962 52968 52956 52960 52770 52776 52753 52758 52745 52750 52460 52466 52454 52458 52173 52179 52156 52161 52148 52153 51877 51883 51871 51875 51604 51610 51587 51592 51579 51584 51312 51318 51306 51310 51047 51053 51030 51035 51022 51027 50749 50755 50743 50747 50476 50482 50459 50464 50451 50456 50443 50448 50287 50293 50281 50285 50124 50130 50107 50112 50100 50104 50092 50097 49880 49886 49874 49878 49661 49667 49644 49649 49620 49625 49470 49475 49252 49258 49246 49250 49025 49031 49008 49013 49000 49005 48838 48844 48832 48836 48669 48675 48652 48657 48644 48649 48444 48450 48438 48442 48229 48235 48212 48217 48204 48209 48035 48041 48029 48033 47851 47857 47834 47839 47826 47831 47433 47439 47427 47431 47042 47048 47025 47030 47017 47022 46798 46804 46792 46796 46552 46558 46535 46540 46527 46532 46305 46311 46299 46303 46055 46061 46038 46043 46030 46035 45763 45769 45757 45761 45493 45499 45476 45481 45468 45473 45211 45217 45205 45209 44951 44957 44934 44939 44926 44931 44716 44722 44710 44714 44496 44502 44479 44484 44471 44476 44196 44202 44190 44194 43919 43925 43902 43907 43894 43899 43750 43756 43744 43748 43599 43605 43582 43587 43574 43579 43386 43392 43380 43384 43183 43189 43166 43171 43158 43163 42970 42976 42964 42968 42778 42784 42761 42766 42753 42758 42567 42573 42561 42565 42378 42384 42361 42366 42353 42358 42193 42199 42187 42191 42019 42025 42002 42007 41863 41869 41736 41741 41440 41446 41434 41438 41145 41151 41128 41133 41120 41125 40917 40923 40911 40915 40705 40711 40688 40693 40680 40685 40527 40533 40521 40525 40365 40371 40348 40353 40340 40345 40150 40156 40144 40148 39952 39958 39935 39940 39927 39932 39790 39796 39784 39788 39648 39654 39631 39636 39623 39628 39433 39439 39427 39431 39235 39241 39218 39223 39210 39215 38999 39005 38993 38997 38778 38784 38761 38766 38753 38758 38583 38589 38577 38581 38405 38411 38388 38393 38380 38385 38210 38216 38204 38208 38032 38038 38015 38020 38007 38012 37836 37842 37830 37834 37657 37663 37640 37645 37632 37637 37478 37484 37472 37476 37317 37323 37300 37305 37292 37297 37119 37125 37113 37117 36938 36944 36921 36926 36913 36918 36713 36719 36707 36711 36504 36510 36487 36492 36479 36484 36269 36275 36263 36267 36048 36054 36031 36036 36023 36028 35875 35881 35869 35873 35719 35725 35702 35707 35694 35699 35491 35497 35485 35489 35237 35243 35220 35225 35087 35092 34825 34831 34819 34823 34561 34567 34544 34549 34536 34541 34372 34378 34366 34370 34200 34206 34183 34188 34011 34016 34003 34008 33995 34000 33741 33745 33341 33346 33309 33311 33302 33306 33188 33193 31832 31836 29297 29302 29279 29284 29030 29035 29022 29027 29015 29020 28951 28957 28898 28904 28867 28869 28808 28814 28761 28767 28755 28759 28693 28699 28632 28638 28571 28577 28514 28520 28450 28456 28383 28389 28321 28327 28263 28269 28206 28212 28148 28154 28093 28099 28032 28038 27975 27981 27920 27926 27867 27873 27811 27817 27755 27761 27700 27706 27643 27649 27587 27593 27532 27538 27477 27483 27421 27427 27366 27372 27312 27318 27255 27261 27203 27209 27150 27156 27098 27104 27044 27050 26994 27000 26943 26949 26891 26897 26841 26847 26790 26796 26740 26746 26689 26695 26635 26641 26585 26591 26534 26540 26481 26487 26426 26432 26375 26381 26358 26363 26234 26240 26195 26201 26158 26164 26117 26123 26048 26054 26010 26016 25969 25975 25928 25934 25857 25863 25816 25822 25780 25786 25744 25750 25706 25712 25668 25674 25357 25359 25349 25354 25341 25346 25334 25339 25272 25278 25221 25227 25190 25192 25132 25138 25086 25092 25080 25084 25020 25026 24971 24977 24920 24926 24870 24876 24815 24821 24760 24766 24704 24710 24651 24657 24592 24598 24537 24543 24479 24485 24424 24430 24372 24378 24324 24330 24275 24281 24225 24231 24177 24183 24124 24130 24076 24082 24025 24031 23965 23971 23916 23922 23867 23873 23805 23811 23757 23763 23703 23709 23649 23655 23596 23602 23544 23550 23489 23495 23435 23441 23382 23388 23329 23335 23275 23281 23222 23228 23170 23176 23115 23121 23066 23072 23015 23021 22956 22962 22903 22909 22854 22860 22837 22842 22726 22732 22699 22705 22672 22678 22645 22651 22618 22624 22591 22597 22564 22570 22537 22543 22510 22516 22483 22489 22456 22462 22429 22435 22402 22408 22375 22381 22348 22354 22321 22327 22294 22300 22267 22273 22240 22246 22213 22219 22186 22192 22159 22165 22132 22138 22105 22111 22078 22084 22051 22057 22024 22030 21997 22003 21970 21976 21943 21949 21916 21922 21889 21895 21862 21868 21835 21841 21808 21814 21781 21787 21754 21760 21727 21733 21700 21706 21673 21679 21646 21652 21619 21625 21592 21598 21565 21571 21538 21544 21511 21517 21484 21490 21457 21463 21430 21436 21403 21409 21376 21382 21349 21355 21322 21328 21295 21301 21268 21274 21173 21179 21122 21128 21072 21078 21020 21026 20970 20976 20916 20922 20866 20872 20815 20821 20761 20767 20707 20713 20662 20668 20617 20623 20570 20576 20523 20529 20470 20476 20416 20422 20367 20373 20318 20324 20268 20274 20217 20223 20166 20172 19807 19809 19799 19804 19791 19796 19784 19789 19721 19727 19669 19675 19638 19640 19580 19586 19534 19540 19528 19532 19468 19474 19419 19425 19368 19374 19318 19324 19263 19269 19208 19214 19152 19158 19099 19105 19040 19046 18985 18991 18927 18933 18872 18878 18820 18826 18772 18778 18723 18729 18673 18679 18625 18631 18572 18578 18524 18530 18473 18479 18413 18419 18364 18370 18315 18321 18253 18259 18205 18211 18151 18157 18097 18103 18044 18050 17992 17998 17937 17943 17883 17889 17830 17836 17777 17783 17723 17729 17670 17676 17618 17624 17563 17569 17514 17520 17463 17469 17404 17410 17351 17357 17302 17308 17285 17290 17174 17180 17147 17153 17120 17126 17093 17099 17066 17072 17039 17045 17012 17018 16985 16991 16958 16964 16931 16937 16904 16910 16877 16883 16850 16856 16823 16829 16796 16802 16769 16775 16742 16748 16715 16721 16688 16694 16661 16667 16634 16640 16607 16613 16580 16586 16553 16559 16526 16532 16499 16505 16472 16478 16445 16451 16418 16424 16391 16397 16364 16370 16337 16343 16310 16316 16283 16289 16256 16262 16229 16235 16202 16208 16175 16181 16148 16154 16121 16127 16094 16100 16067 16073 16040 16046 16013 16019 15986 15992 15959 15965 15932 15938 15905 15911 15878 15884 15851 15857 15824 15830 15797 15803 15770 15776 15743 15749 15716 15722 15621 15627 15570 15576 15520 15526 15468 15474 15418 15424 15364 15370 15314 15320 15263 15269 15209 15215 15155 15161 15110 15116 15065 15071 15018 15024 14971 14977 14918 14924 14864 14870 14815 14821 14766 14772 14716 14722 14665 14671 14614 14620 14252 14254 14244 14249 13886 13888 13769 13775 13653 13659 13539 13545 13425 13431 12961 12967 12802 12808 12757 12763 12706 12711 12675 12681 12644 12650 12614 12620 12608 12612 12577 12583 12543 12549 12516 12522 12492 12494 12324 12329 12316 12321 12289 12295 12259 12265 12253 12257 12228 12234 12184 12190 12172 12177 12165 12169 12134 12140 12109 12111 12101 12106 12080 12087 12059 12065 12047 12052 12018 12024 11994 12000 11969 11975 11689 11695 11637 11642 11589 11595 11583 11587 11366 11372 11343 11345 11296 11301 11172 11178 11166 11170 10703 10709 10679 10681 10463 10469 10344 10350 10276 10282 10183 10189 10059 10065 9519 9525 9406 9412 9166 9171 9147 9153 9141 9145 9122 9128 9106 9111 8989 8994 8922 8926 8729 8734 8583 8589 8555 8561 8527 8533 8499 8505 8471 8477 8443 8449 8415 8421 8387 8393 8359 8365 8331 8337 8269 8275 8250 8256 8231 8237 8212 8218 8193 8199 8116 8122 8095 8101 8075 8081 8055 8061 8035 8041 8015 8021 7934 7940 7868 7874 7799 7805 7703 7709 7667 7673 7595 7601 7529 7535 7451 7457 7389 7395 7350 7356 7278 7284 7270 7275 7213 7219 7161 7167 7053 7059 6984 6990 6939 6945 6894 6900 6813 6819 6724 6730 6672 6678 6592 6598 6544 6550 6496 6502 6449 6455 6404 6410 6357 6363 6285 6291 6184 6190 6132 6138 6049 6055 5998 6004 5945 5951 5896 5902 5866 5870 5690 5696 5649 5655 5532 5538 5444 5450 5380 5386 5316 5322 5236 5242 5134 5140 5070 5076 4972 4978 4908 4914 4844 4850 4780 4786 4716 4722 4652 4658 4589 4595 4493 4499 4430 4436 4367 4373 4254 4260 4191 4197 4097 4103 4034 4040 3971 3977 3908 3914 3866 3871 3495 3500 3434 3438 3308 3313 2656 2661 2648 2653 2539 2543 2461 2466 2441 2447 1649 1654 1642 1647 1618 1622 1581 1586 1550 1552 1099 1104 1063 1069 1027 1033 996 1002 962 968 925 931 892 898 859 865 852 856 823 829 795 801 767 773 739 745 711 717 683 689 655 661 637 642 135 142 17 23 2 8)))) --- blacs-mpi-1.1.orig/SRC/MPI/INTERNAL/BI_GetMpiTrType.c +++ blacs-mpi-1.1/SRC/MPI/INTERNAL/BI_GetMpiTrType.c @@ -98,6 +98,24 @@ } } } +#ifdef T3ETrError +/* + * Get rid of 0-length segments to keep T3E happy + */ + for (i=0; i < n; i++) + { + if (len[i] == 0) + { + for (k=i+1; k < n; k++) + { + len[k-1] = len[k]; + disp[k-1] = disp[k]; + } + if (n > 0) n--; + i--; /* check new entry for 0-byte */ + } + } +#endif BI_MPI_Type_indexed(n, len, disp, Dtype, &TrType, i); BI_MPI_Type_commit(&TrType, i); --- blacs-mpi-1.1.orig/SRC/MPI/INTERNAL/BI_MPI_C_to_f77_trans_comm.c +++ blacs-mpi-1.1/SRC/MPI/INTERNAL/BI_MPI_C_to_f77_trans_comm.c @@ -1,5 +1,7 @@ #include "Bdef.h" /* This file from mpiblacs_patch01 */ +/* This file subsequently hacked by author to add support for MPI2.0 translation + mechanisms */ void BI_MPI_C_to_f77_trans_comm(MPI_Comm Ccomm, int *F77comm) /* @@ -14,6 +16,13 @@ { /* + * If your packages supports MPI 2.0's translation mechanisms + */ +#if (BI_TransComm == USEMPI2) + *F77comm = MPI_Comm_c2f(Ccomm); +#endif + +/* * If the MPI we're using is based on MPICH, can use MPICH's internal * translation routines (I found these routines in MPICH version 1.0.9, * June, 1995). @@ -69,9 +78,12 @@ { MPI_Group_translate_ranks(Ugrp, 1, &i, Wgrp, &pmap[i]); } + MPI_Group_free(&Wgrp); + MPI_Group_free(&Ugrp); mpi_comm_group_(BI_F77_MPI_COMM_WORLD, &ugrp, &i); mpi_group_incl_(&ugrp, &Np, pmap, &bgrp, &i); + mpi_group_free_(&ugrp, &i); free(pmap); mpi_comm_create_(BI_F77_MPI_COMM_WORLD, &bgrp, F77comm, &i); mpi_group_free_(&bgrp, &i); --- blacs-mpi-1.1.orig/SRC/MPI/INTERNAL/BI_MPI_F77_to_c_trans_comm.c +++ blacs-mpi-1.1/SRC/MPI/INTERNAL/BI_MPI_F77_to_c_trans_comm.c @@ -1,5 +1,5 @@ #include "Bdef.h" -/* This file from mpiblacs_patch01 */ +/* This file from mpiblacs_patch01, hacked by author to add MPI2 support */ void BI_MPI_F77_to_c_trans_comm(int F77comm, MPI_Comm *Ccomm) /* @@ -14,6 +14,13 @@ { /* + * If your packages supports MPI 2.0's translation mechanisms + */ +#if (BI_TransComm == USEMPI2) + *Ccomm = MPI_Comm_f2c(F77comm); +#endif + +/* * If the MPI we're using is based on MPICH, can use MPICH's internal * translation * routines (I found these routines in MPICH version 1.0.9, * June, 1995). @@ -66,9 +73,12 @@ { mpi_group_translate_ranks_(&Fgrp, &one, &i, &Wgrp, &pmap[i], &ierr); } + mpi_group_free_(&Wgrp, &ierr); + mpi_group_free_(&Fgrp, &ierr); MPI_Comm_group(MPI_COMM_WORLD, &wgrp); MPI_Group_incl(wgrp, Np, pmap, &cgrp); + MPI_Group_free(&wgrp); free(pmap); MPI_Comm_create(MPI_COMM_WORLD, cgrp, Ccomm); MPI_Group_free(&cgrp); --- blacs-mpi-1.1.orig/SRC/MPI/INTERNAL/BI_TransUserComm.c +++ blacs-mpi-1.1/SRC/MPI/INTERNAL/BI_TransUserComm.c @@ -42,6 +42,8 @@ MPI_Group_translate_ranks(Ugrp, 1, &k, Wgrp, &pmap[i]); } ucomm = *BI_F77_MPI_COMM_WORLD; + MPI_Group_free(&Ugrp); + MPI_Group_free(&Wgrp); #else int Ugrp, Wgrp, ierr, one=1; @@ -53,6 +55,8 @@ mpi_group_translate_ranks_(&Ugrp, &one, &k, &Wgrp, &pmap[i], &ierr); } ucomm = MPI_COMM_WORLD; + mpi_group_free_(&Ugrp, &ierr); + mpi_group_free_(&Wgrp, &ierr); #endif #else @@ -68,6 +72,7 @@ BI_MPI_Comm_group(ucomm, &ugrp, i); BI_MPI_Group_incl(ugrp, Np, pmap, &bgrp, i); BI_MPI_Comm_create(ucomm, bgrp, &bcomm, i); + BI_MPI_Group_free(&ugrp, i); BI_MPI_Group_free(&bgrp, i); return(bcomm); --- blacs-mpi-1.1.orig/SRC/MPI/INTERNAL/bi_f77_get_constants.f +++ blacs-mpi-1.1/SRC/MPI/INTERNAL/bi_f77_get_constants.f @@ -1,3 +1,9 @@ + subroutine bi_f77_init() + integer ierr + call mpi_init(ierr) + return + end + * SUBROUTINE BI_F77_GET_CONSTANTS(F77COMMWORLD, SETUP, CONST) INCLUDE 'mpif.h' --- blacs-mpi-1.1.orig/SRC/MPI/Makefile +++ blacs-mpi-1.1/SRC/MPI/Makefile @@ -193,9 +193,9 @@ bi_f77_mpi_testall.o : mpif.h bi_f77_mpi_testall.f $(F77) -c $(F77FLAGS) $*.f -mpif.h : $(MPIINCdir)/mpif.h +mpif.h: $(MPIINCdir)/mpif.h rm -f mpif.h - ln -s $(MPIINCdir)/mpif.h mpif.h + ln -s $< $@ # ------------------------------------------------------------------------ # We move C .o files to .C so that we can use the portable suffix rule for --- blacs-mpi-1.1.orig/SRC/MPI/blacs_gridmap_.c +++ blacs-mpi-1.1/SRC/MPI/blacs_gridmap_.c @@ -46,9 +46,9 @@ BI_Stats = (BI_MPI_Status *) malloc(BI_Np * BI_MPI_STATUS_SIZE * sizeof(BI_MPI_Status)); #ifndef UseF77Mpi - BI_MPI_Type_contiguous(2, MPI_FLOAT, &BI_MPI_COMPLEX, info); + BI_MPI_Type_contiguous(2, BI_MPI_FLOAT, &BI_MPI_COMPLEX, info); BI_MPI_Type_commit(&BI_MPI_COMPLEX, info); - BI_MPI_Type_contiguous(2, MPI_DOUBLE, &BI_MPI_DOUBLE_COMPLEX, info); + BI_MPI_Type_contiguous(2, BI_MPI_DOUBLE, &BI_MPI_DOUBLE_COMPLEX, info); BI_MPI_Type_commit(&BI_MPI_DOUBLE_COMPLEX, info); #endif } @@ -82,6 +82,7 @@ MPI_Comm_group(Ucomm, &Cgrp); /* find input comm's group */ MPI_Group_incl(Cgrp, Ng, iptr, &Cgrp2); /* form new group */ MPI_Comm_create(Ucomm, Cgrp2, &Ccomm); /* create new comm */ + MPI_Group_free(&Cgrp); MPI_Group_free(&Cgrp2); #endif #else @@ -102,6 +103,7 @@ mpi_group_incl_(&Fgrp, &Ng, iptr, &Fgrp2, &info); mpi_comm_create_(ConTxt, &Fgrp2, Fcomm, &info); mpi_group_free_(&Fgrp2, &info); + mpi_group_free_(&Fgrp, &info); #endif #endif @@ -112,6 +114,7 @@ BI_MPI_Group_incl(grp, Ng, iptr, &tgrp, info); /* form new group */ BI_MPI_Comm_create(tcomm, tgrp, &comm, info); /* create new comm */ BI_MPI_Group_free(&tgrp, info); + BI_MPI_Group_free(&grp, info); #endif /* * Weed out callers who are not participating in present grid --- blacs-mpi-1.1.orig/SRC/MPI/blacs_pinfo_.c +++ blacs-mpi-1.1/SRC/MPI/blacs_pinfo_.c @@ -20,7 +20,7 @@ */ MPI_Initialized(nprocs); #ifdef MainInF77 - if (!(*nprocs)) mpi_init_(&ierr); + if (!(*nprocs)) bi_f77_init_(); #else if (!(*nprocs)) BI_BlacsErr(-1, -1, __FILE__, --- blacs-mpi-1.1.orig/SRC/MPI/cgamn2d_.c +++ blacs-mpi-1.1/SRC/MPI/cgamn2d_.c @@ -1,5 +1,8 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif #if (INTFACE == C_CALL) void Ccgamn2d(int ConTxt, char *scope, char *top, int m, int n, float *A, --- blacs-mpi-1.1.orig/SRC/MPI/cgamx2d_.c +++ blacs-mpi-1.1/SRC/MPI/cgamx2d_.c @@ -1,5 +1,8 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif #if (INTFACE == C_CALL) void Ccgamx2d(int ConTxt, char *scope, char *top, int m, int n, float *A, --- blacs-mpi-1.1.orig/SRC/MPI/dgamn2d_.c +++ blacs-mpi-1.1/SRC/MPI/dgamn2d_.c @@ -1,5 +1,8 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif #if (INTFACE == C_CALL) void Cdgamn2d(int ConTxt, char *scope, char *top, int m, int n, double *A, --- blacs-mpi-1.1.orig/SRC/MPI/dgamx2d_.c +++ blacs-mpi-1.1/SRC/MPI/dgamx2d_.c @@ -1,5 +1,8 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif #if (INTFACE == C_CALL) void Cdgamx2d(int ConTxt, char *scope, char *top, int m, int n, double *A, --- blacs-mpi-1.1.orig/SRC/MPI/dwalltime00_.c +++ blacs-mpi-1.1/SRC/MPI/dwalltime00_.c @@ -6,5 +6,6 @@ F_DOUBLE_FUNC dwalltime00_(void) #endif { - return(BI_MPI_Wtime()); +/* return(BI_MPI_Wtime()); */ + return(MPI_Wtime()); } --- blacs-mpi-1.1.orig/SRC/MPI/igamn2d_.c +++ blacs-mpi-1.1/SRC/MPI/igamn2d_.c @@ -1,5 +1,8 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif #if (INTFACE == C_CALL) void Cigamn2d(int ConTxt, char *scope, char *top, int m, int n, int *A, --- blacs-mpi-1.1.orig/SRC/MPI/igamx2d_.c +++ blacs-mpi-1.1/SRC/MPI/igamx2d_.c @@ -1,5 +1,9 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif + #if (INTFACE == C_CALL) void Cigamx2d(int ConTxt, char *scope, char *top, int m, int n, int *A, --- blacs-mpi-1.1.orig/SRC/MPI/sgamn2d_.c +++ blacs-mpi-1.1/SRC/MPI/sgamn2d_.c @@ -1,5 +1,8 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif #if (INTFACE == C_CALL) void Csgamn2d(int ConTxt, char *scope, char *top, int m, int n, float *A, --- blacs-mpi-1.1.orig/SRC/MPI/sgamx2d_.c +++ blacs-mpi-1.1/SRC/MPI/sgamx2d_.c @@ -1,5 +1,8 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif #if (INTFACE == C_CALL) void Csgamx2d(int ConTxt, char *scope, char *top, int m, int n, float *A, --- blacs-mpi-1.1.orig/SRC/MPI/zgamn2d_.c +++ blacs-mpi-1.1/SRC/MPI/zgamn2d_.c @@ -1,5 +1,8 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif #if (INTFACE == C_CALL) void Czgamn2d(int ConTxt, char *scope, char *top, int m, int n, double *A, --- blacs-mpi-1.1.orig/SRC/MPI/zgamx2d_.c +++ blacs-mpi-1.1/SRC/MPI/zgamx2d_.c @@ -1,5 +1,8 @@ #include "Bdef.h" +#ifdef T3EReductErr + #define DefCombTop '1' +#endif #if (INTFACE == C_CALL) void Czgamx2d(int ConTxt, char *scope, char *top, int m, int n, double *A, --- blacs-mpi-1.1.orig/TESTING/Cbt.c +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/Cbt.h +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/Makefile +++ blacs-mpi-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 $< $@ + +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 $(TESTdir)/*.dat + +.f.o: ; $(F77) -c $(F77FLAGS) $*.f --- blacs-mpi-1.1.orig/TESTING/README +++ blacs-mpi-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. --- blacs-mpi-1.1.orig/TESTING/blacstest.f +++ blacs-mpi-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 +* --- blacs-mpi-1.1.orig/TESTING/bsbr.dat +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/bt.dat +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/btprim_CMMD.f +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/btprim_MPI.f +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/btprim_MPL.f +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/btprim_NX.f +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/btprim_PVM.f +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/comb.dat +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/TESTING/s.sh +++ blacs-mpi-1.1/TESTING/s.sh @@ -0,0 +1 @@ +gfortran -o /tmp/blacs-mpi/blacs-mpi-1.1/TESTING/EXE/xFbtest_MPI-LINUX-0-static-lam blacstest.o btprim_MPI.o tools.o /tmp/blacs-mpi/blacs-mpi-1.1/LIB/blacsF77init_MPI-LINUX-0.a /tmp/blacs-mpi/blacs-mpi-1.1/LIB/blacs_MPI-LINUX-0.a /tmp/blacs-mpi/blacs-mpi-1.1/LIB/blacsF77init_MPI-LINUX-0.a /tmp/blacs-mpi/blacs-mpi-1.1/LIB/*.a -L/usr/lib/lam/lib -llam --- blacs-mpi-1.1.orig/TESTING/sdrv.dat +++ blacs-mpi-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-mpi-1.1.orig/TESTING/tools.f +++ blacs-mpi-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 --- blacs-mpi-1.1.orig/debian/blacs-mpi-implementations.patch +++ blacs-mpi-1.1/debian/blacs-mpi-implementations.patch @@ -0,0 +1,161 @@ +diff -Nru blacs-mpi-1.1.orig//Bmake.inc blacs-mpi-1.1//Bmake.inc +--- blacs-mpi-1.1.orig//Bmake.inc 2011-08-15 21:08:36.474630178 -0700 ++++ blacs-mpi-1.1//Bmake.inc 2011-08-15 21:11:41.535007658 -0700 +@@ -1,4 +1,38 @@ + #============================================================================= ++#=========================== 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. ++# ++# This section has been moved before Section 1 to allow redefinition of the ++# F77 and CC options in the MPI implementation specific clauses. ++#============================================================================= ++ F77 = gfortran ++ F77NO_OPTFLAGS = $(FPIC) -w ++ F77FLAGS = $(F77NO_OPTFLAGS) -O4 ++ F77LOADER = $(F77) ++ F77LOADFLAGS = ++ CC = cc ++ CCFLAGS = $(FPIC) -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 =============================== ++#============================================================================= ++ ++ ++#============================================================================= + #====================== SECTION 1: PATHS AND LIBRARIES ======================= + #============================================================================= + # The following macros specify the name and location of libraries required by +@@ -44,24 +78,38 @@ + BLACSCINIT = $(BLACSdir)/blacsCinit_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + BLACSLIB = $(BLACSdir)/blacs_$(COMMLIB)-$(PLAT)-$(BLACSDBGLVL).a + ++# Default unless overridden below: ++ CC = cc ++ + # ------------------------------------- + # Name and location of the MPI library. + # ------------------------------------- + ifeq ($(MPI),mpich) + # for compilation with mpich: + MPIdir = /usr/lib/mpich +- MPIdev = ch_p4 +- MPIplat = LINUX + MPILIBdir = $(MPIdir)/lib + MPIINCdir = $(MPIdir)/include +- MPILIB = $(MPILIBdir)/shared/libmpich.so $(MPILIBdir)/shared/libpmpich.so $(MPILIBdir)/libmpich.a +-else ++ MPILIB = -lmpich ++ CC = mpicc.mpich ++ F77 = mpif90.mpich ++endif ++ifeq ($(MPI),lam) + # for compilation with lam: + MPILIBdir = /usr/lib/lam/lib + MPIINCdir = /usr/include/lam + MPILIB = -L/usr/lib/lam/lib -llam ++ CC = mpicc.lam ++ F77 = mpif90.lam ++endif ++ifeq ($(MPI),openmpi) ++# for compilation with openmpi: ++ MPIdir = /usr/lib/openmpi ++ MPILIBdir = $(MPIdir)/lib ++ MPIINCdir = $(MPIdir)/include ++ MPILIB = -L/usr/lib/openmpi/lib -lmpi -lmpi_f77 ++ CC = mpicc.openmpi ++ F77 = mpif90.openmpi + endif +- + + # ------------------------------------- + # All libraries required by the tester. +@@ -98,11 +146,7 @@ + # The directory to find the required communication library include files, + # if they are required by your system. + # ----------------------------------------------------------------------- +-ifeq ($(MPI),mpich) +- SYSINC = -I$(MPIINCdir) -I$(MPIdir)/build/$(MPIplat)/$(MPIdev)/include +-else +- SYSINC = -I$(MPIINCdir) +-endif ++SYSINC = -I$(MPIINCdir) + + # --------------------------------------------------------------------------- + # The Fortran 77 to C interface to be used. If you are unsure of the correct +@@ -208,33 +252,3 @@ + #=============================== 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 +- F77NO_OPTFLAGS = $(FPIC) -w +- F77FLAGS = $(F77NO_OPTFLAGS) -O4 +- F77LOADER = $(F77) +- F77LOADFLAGS = +- CC = cc +- CCFLAGS = $(FPIC) -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 =============================== +-#============================================================================= +diff -Nru blacs-mpi-1.1.orig/SRC/MPI/Makefile blacs-mpi-1.1/SRC/MPI/Makefile +--- blacs-mpi-1.1.orig/SRC/MPI/Makefile 2011-08-15 20:33:19.000000000 -0700 ++++ blacs-mpi-1.1/SRC/MPI/Makefile 2011-08-15 20:34:39.870603642 -0700 +@@ -194,8 +194,8 @@ + $(F77) -c $(F77FLAGS) $*.f + + mpif.h: $(MPIINCdir)/mpif.h +- rm -f mpif.h +- ln -s $< $@ ++ rm -f mpif* ++ ln -s $(MPIINCdir)/mpif* . + + # ------------------------------------------------------------------------ + # We move C .o files to .C so that we can use the portable suffix rule for +diff -Nru blacs-mpi-1.1.orig/TESTING/Makefile blacs-mpi-1.1/TESTING/Makefile +--- blacs-mpi-1.1.orig/TESTING/Makefile 2011-08-15 20:33:19.000000000 -0700 ++++ blacs-mpi-1.1/TESTING/Makefile 2011-08-15 20:34:39.870603642 -0700 +@@ -59,8 +59,8 @@ + $(F77) -c $(F77FLAGS) $*.f + + mpif.h: $(MPIINCdir)/mpif.h +- rm -f mpif.h +- ln -s $< $@ ++ rm -f mpif* ++ ln -s $(MPIINCdir)/mpif* . + + fpvm3.h : $(PVMINCdir)/fpvm3.h + rm -f fpvm3.h --- blacs-mpi-1.1.orig/debian/blacs-mpi-test.README.Debian +++ blacs-mpi-1.1/debian/blacs-mpi-test.README.Debian @@ -0,0 +1,8 @@ +You need write access to be able to run the tester applications. +Suggestion: + +$ cp /usr/lib/blacs/* /tmp +$ cd /tmp +$ mpirun.mpich -np 4 cblacs_test_shared-mpich + +etc. --- blacs-mpi-1.1.orig/debian/blacs-mpi-test.dirs +++ blacs-mpi-1.1/debian/blacs-mpi-test.dirs @@ -0,0 +1 @@ +usr/lib/blacs --- blacs-mpi-1.1.orig/debian/blacs-test-common.dirs +++ blacs-mpi-1.1/debian/blacs-test-common.dirs @@ -0,0 +1 @@ +usr/lib/blacs --- blacs-mpi-1.1.orig/debian/changelog +++ blacs-mpi-1.1/debian/changelog @@ -0,0 +1,331 @@ +blacs-mpi (1.1-31.3ubuntu2) utopic; urgency=medium + + * debian/rules: Move arm64 to OPENMPI_ARCHS to fix FTBFS. + + -- Logan Rosen Tue, 20 May 2014 01:59:33 -0400 + +blacs-mpi (1.1-31.3ubuntu1) utopic; urgency=medium + + * Merge from Debian unstable. Remaining changes: + - debian/rules: Declare library dependencies correctly. + + -- Logan Rosen Tue, 20 May 2014 01:44:09 -0400 + +blacs-mpi (1.1-31.3) unstable; urgency=medium + + * Non-maintainer upload. + * Drop transitional package libblacs-mpi1: it breaks reverse + dependencies on mpich archs, because of the mpich2->mpich transition. + + -- Sébastien Villemot Wed, 23 Apr 2014 14:33:08 +0200 + +blacs-mpi (1.1-31.2) unstable; urgency=medium + + * Non-maintainer upload. + * No longer silently change the SONAME of the MPI blacs shared + library when the default MPI implementation changes on a given arch. + (Closes: #740764) + + Create two new binary packages libblacs-openmpi1 and + libblacs-mpich1, corresponding to the two possible SONAMES. + + The architecture list for each binary package is stored in debian/rules, + and debian/control is now generated from debian/control.in by the clean + rule. + + Keep a transitional package for libblacs-mpi1. + + Make sure that the package FTBFS if the default MPI implementation + changes on a given arch (instead of silently changing the SONAME or + creating an empty package). + + -- Sébastien Villemot Thu, 03 Apr 2014 16:31:07 +0200 + +blacs-mpi (1.1-31.1ubuntu1) trusty; urgency=medium + + * Merge from Debian unstable. Remaining changes: + - debian/rules: Declare library dependencies correctly. + + -- Logan Rosen Sat, 28 Dec 2013 17:57:10 -0500 + +blacs-mpi (1.1-31.1) unstable; urgency=medium + + * Non-maintainer upload. + * Support MPICH3 which is now simply called MPICH. (Closes: #731225) + + -- Sébastien Villemot Sun, 22 Dec 2013 13:25:27 +0000 + +blacs-mpi (1.1-31ubuntu2) trusty; urgency=medium + + * No-change rebuild for libopenmpi1.3 -> libopenmpi1.6 transition. + + -- Logan Rosen Sun, 15 Dec 2013 00:37:01 -0500 + +blacs-mpi (1.1-31ubuntu1) precise; urgency=low + + * debian/rules: declare library dependencies correctly (LP: #934138). + + -- Robie Basak Fri, 17 Feb 2012 12:06:41 +0000 + +blacs-mpi (1.1-31) unstable; urgency=low + + * Rebuilding with mpi-default-dev >=1.0 (Closes: #652312) + + -- Muammar El Khatib Fri, 23 Dec 2011 20:40:53 +0100 + +blacs-mpi (1.1-30.1) unstable; urgency=low + + * Non-maintainer upload. + * Add support for ARCH_DEFAULT_MPI_IMPL from mpi-default-dev. + * Add support for MPICH2. Rename debian/blacs-openmpi.patch to the more + general blacs-mpi-implementations.patch. (Closes: #626336) + + -- Nicholas Breen Mon, 15 Aug 2011 20:29:30 -0700 + +blacs-mpi (1.1-30) unstable; urgency=low + + * blacs-mpi source does not Build-Depends on libopenmpi-dev anymore. With + this change it is possible to prevent BLACS from building on architectures + without OpenMPI such as: armel, hppa, mips[el] and s390. (Closes: #620393). + * Thanks to Adam C Powell IV for reporting this bug, and providing a patch. + + -- Muammar El Khatib Sat, 02 Apr 2011 14:42:54 +0200 + +blacs-mpi (1.1-29) unstable; urgency=low + + * Fixed FTBFS because of a dpkg-shlibdeps error that was not able to find + the library libmpi_f77.so.0. (Closes: #614528) + * Maintainer's mail has been changed. + * Bump Standards-Version to 3.9.1. No changes were needed. + * Moved to debhelper 7. + + -- Muammar El Khatib Sun, 27 Mar 2011 14:57:41 +0200 + +blacs-mpi (1.1-28.2) unstable; urgency=low + + * NMU as authorized by maintainer. + * Fixed shared library symlinks broken by -28.1. + * Added sections to libblacs-mpi-dev, blacs-mpi-test and blacs-test-common. + + -- Adam C. Powell, IV Mon, 04 May 2009 19:14:02 -0400 + +blacs-mpi (1.1-28.1) unstable; urgency=low + + * NMU as authorized by maintainer. + * Changed to build against mpi-default-dev. (Closes: #491105) + * Replaced two sets of shlib, -dev and -test packages with just one. + * Changed binary package names to generic mpi and to comply with policy + i.e. libblacs-mpi1 and libblacs-mpi-dev. + + -- Adam C. Powell, IV Mon, 27 Apr 2009 14:36:28 -0400 + +blacs-mpi (1.1-28) unstable; urgency=low + + * The package now Build-Depends on Gfortran. + * Homepage was moved from blacs-mpi's description to control tag. + * Bump Standards-Version to 3.7.3 + * Bug 'FTBFS: btprim_MPI.f:(.text+0x56): undefined reference to + `mpi_type_size__' has been fixed in this revision. (Closes: #465638) + * Bug 'blacs-mpi -- Please rebuild with gfortran and new lam, mpich' has + been fixed in this revision. Thanks to Kumar Appaiah for providing a + patch. (Closes: #465366) + + -- Muammar El Khatib Sat, 16 Feb 2008 11:21:29 -0430 + +blacs-mpi (1.1-27) unstable; urgency=low + + * New maintainer. Closes: #335008 + * Bumped standards version to 3.7.2 + * Updated build dependency to debhelper >= 4. + + -- Muammar El Khatib Sun, 3 Sep 2006 18:48:15 +0000 + +blacs-mpi (1.1-26) unstable; urgency=low + + * Upgraded build dependency for lam + + -- Philipp Frauenfelder Sat, 3 Sep 2005 14:04:19 +0200 + +blacs-mpi (1.1-25) unstable; urgency=low + + * Recompile for C++ transitioned mpich (changed build dependecies). + Closes: #325808 + + -- Philipp Frauenfelder Wed, 31 Aug 2005 23:04:37 +0200 + +blacs-mpi (1.1-24) unstable; urgency=low + + * Removed cyclic dependency according to + http://debian.semistable.com/debgraph.out + by removing depends line in blacs-test-common + + -- Philipp Frauenfelder Tue, 12 Jul 2005 22:51:44 +0200 + +blacs-mpi (1.1-23) unstable; urgency=low + + * Reverted changes in last version as Bug #280789 was in MPICH and + is fixed by version 1.2.5.3-1.1 of mpich. Adapted build-depends to + reflect this. + + -- Philipp Frauenfelder Wed, 8 Dec 2004 21:53:36 +0100 + +blacs-mpi (1.1-22) unstable; urgency=low + + * Recompiled with updated MPICH, adapted Bmake.inc. Closes: #280789 + + -- Philipp Frauenfelder Thu, 11 Nov 2004 22:41:30 +0100 + +blacs-mpi (1.1-21) unstable; urgency=low + + * Removed explicit linking against libutil for LAM as liblam is now linked + against it. Version build depends against lam4-dev because of this + and other linking problems (libpthread). + + -- Philipp Frauenfelder Thu, 19 Feb 2004 09:34:16 +0100 + +blacs-mpi (1.1-20) unstable; urgency=low + + * Recompile again with corrected rules file. + + -- Philipp Frauenfelder Mon, 9 Feb 2004 14:21:20 +0100 + +blacs-mpi (1.1-19) unstable; urgency=low + + * Recompile with correct dependency for blacs1-lam. + Closes: #229938 + + -- Philipp Frauenfelder Sun, 1 Feb 2004 14:59:14 +0100 + +blacs-mpi (1.1-18) unstable; urgency=low + + * Rebuilt against lam4 (upgraded build depends) + + -- Philipp Frauenfelder Sat, 24 Jan 2004 17:55:32 +0100 + +blacs-mpi (1.1-17) unstable; urgency=low + + * Changed package description. Closes: #209502, #20943, #209464, #209442 + * Bumped standards version to 3.6.1 + * Added -lutil to LAM linking (already in earlier versions). Closes: #187842 + * Dynamically link against MPICH. + + -- Philipp Frauenfelder Wed, 17 Sep 2003 14:07:19 +0200 + +blacs-mpi (1.1-16) unstable; urgency=low + + * Recompiled with new MPI library path settings and some other fixes + to the build process. Closes: #189684 + * Bumped standards version to 3.5.9 + + -- Philipp Frauenfelder Tue, 22 Apr 2003 14:36:35 +0200 + +blacs-mpi (1.1-15) unstable; urgency=low + + * Changed section of blacs1-mpich and blacs1-lam from devel to libs + and added some depends. + + -- Philipp Frauenfelder Fri, 3 Aug 2001 15:57:15 +0000 + +blacs-mpi (1.1-14) unstable; urgency=low + + * Recompile against new lam 6.5.3 (in the lam3 and lam3-dev packages) + which is binary incompatible with the previous lam 6.5.2 (lam2). + Added a blacs1-lam.shlibs file to reflect this incompatibility. + + -- Philipp Frauenfelder Mon, 23 Jul 2001 06:31:29 +0000 + +blacs-mpi (1.1-13) unstable; urgency=low + + * Forgot to close this bug in the last release: Closes: #70305 + * Changes for new mpich version. Closes: #71067 + + -- Philipp Frauenfelder Fri, 8 Sep 2000 10:46:45 +0200 + +blacs-mpi (1.1-12) unstable; urgency=low + + * Added Build-Depends. Closes: #66541, #70933 + * Standards-Version: 3.2.1 + + -- Philipp Frauenfelder Wed, 6 Sep 2000 09:59:48 +0200 + +blacs-mpi (1.1-11) frozen unstable; urgency=medium + + * Corrected dependencies (which were plain wrong: blacs-lam-test depended + on blacs1-mpich). No other changes. + Release Manager: this should go into frozen since before, it was not + possible to install the mpich and lam versions of blacs independently. + + -- Philipp Frauenfelder Tue, 11 Jul 2000 09:04:30 +0200 + +blacs-mpi (1.1-10) frozen unstable; urgency=medium + + * Changed recommendation of blacs-lam-test from scalapack1-lam-test + to scalapack-lam-test. Closes: #62862 + * Removed all recommendations and suggestions since I have problems + with scalapack. Closes: #63466, #63467, #63468, #63469, #63470 + + -- Philipp Frauenfelder Sat, 6 May 2000 07:35:28 +0200 + +blacs-mpi (1.1-9) frozen; urgency=low + + * Recompiled on potato. + + -- Philipp Frauenfelder Sat, 22 Apr 2000 16:52:24 +0200 + +blacs-mpi (1.1-8) unstable; urgency=low + + * Added a binary-arch target to rules which was missing before. + Closes: #52843. + + -- Philipp Frauenfelder Thu, 16 Dec 1999 16:38:02 +0100 + +blacs-mpi (1.1-7) unstable; urgency=low + + * Deleted creation of TESTING/EXE to build targets which I forgot + for -6. Thanks to Roman Hodek. This should really Closes: #51932. + + -- Philipp Frauenfelder Tue, 7 Dec 1999 15:06:14 +0100 + +blacs-mpi (1.1-6) unstable; urgency=low + + * Moved creation of TESTING/EXE to build targets in debian/rules. + Closes: #51632. + + -- Philipp Frauenfelder Tue, 30 Nov 1999 16:45:20 +0100 + +blacs-mpi (1.1-5) unstable; urgency=low + + * Recompilation because of broken .dsc file. Closes: #50509 + * Added creation of TESTING/EXE to rules. + + -- Philipp Frauenfelder Thu, 18 Nov 1999 11:57:13 +0100 + +blacs-mpi (1.1-4) unstable; urgency=low + + * Now build packages for LAM and MPICH, can be installed together! + * Compile shared libraries too; new package libblacs1-{mpich,lam} with + these included. libblacs-{mpich,lam}-{dev,test} are also new + (links and static libs). libblacs-test-common includes some data files + needed for the testing applications. + Thanks to Camm Maguire + * Applied mpiblacs-patch02.tgz from http://www.netlib.org/blacs/. + + -- Philipp Frauenfelder Mon, 11 Oct 1999 12:55:19 +0200 + +blacs-mpi (1.1-3) unstable; urgency=low + + * Changed priority from optional to extra to stay in sync with blacs-pvm. + * Bumped standards version to 3.0.1. + * Moved to debhelper v2. + + -- Philipp Frauenfelder Thu, 19 Aug 1999 11:43:26 +0200 + +blacs-mpi (1.1-2) unstable; urgency=low + + * Changed path in Bmake.inc, closes #37402 + * Changed binary-arch and binary-indep in debian/rules, closes + #37403 (which is against blacs-pvm but applies here too) + + -- Philipp Frauenfelder Mon, 10 May 1999 18:37:11 +0200 + +blacs-mpi (1.1-1) unstable; urgency=low + + * Initial release. + + -- Philipp Frauenfelder Sat, 24 Apr 1999 11:29:51 +0200 --- blacs-mpi-1.1.orig/debian/compat +++ blacs-mpi-1.1/debian/compat @@ -0,0 +1 @@ +7 --- blacs-mpi-1.1.orig/debian/control +++ blacs-mpi-1.1/debian/control @@ -0,0 +1,120 @@ +# This file is autogenerated. DO NOT EDIT! +# +# Modifications should be made to debian/control.in instead. +# This file is regenerated automatically in the clean target. + +Source: blacs-mpi +Section: devel +Priority: extra +Maintainer: Ubuntu Developers +XSBC-Original-Maintainer: Muammar El Khatib +Standards-Version: 3.9.1 +Build-Depends: debhelper (>= 7), mpi-default-dev (>= 1.0), gfortran +Homepage: http://www.netlib.org/blacs/ + +Package: libblacs-openmpi1 +Section: libs +Architecture: alpha amd64 armel armhf arm64 hurd-i386 i386 kfreebsd-amd64 kfreebsd-i386 mips mipsel powerpc sparc +Depends: mpi-default-bin, ${shlibs:Depends}, ${misc:Depends} +Breaks: libblacs-mpi1 (<< 1.1-31.2) +Replaces: blacs1-mpich, blacs1gf-mpich, blacs1-lam, blacs1gf-lam, + libblacs-mpi1 (<< 1.1-31.2) +Conflicts: blacs1-mpich, blacs1gf-mpich, blacs1-lam, blacs1gf-lam +Description: Basic Linear Algebra Comm. Subprograms - Shared libs. for OpenMPI + 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 MPI. 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: libblacs-mpich1 +Section: libs +Architecture: hppa m68k powerpcspe ppc64 s390x sparc64 +Depends: mpi-default-bin, ${shlibs:Depends}, ${misc:Depends} +Breaks: libblacs-mpi1 (<< 1.1-31.2) +Replaces: blacs1-mpich, blacs1gf-mpich, blacs1-lam, blacs1gf-lam, + libblacs-mpi1 (<< 1.1-31.2) +Conflicts: blacs1-mpich, blacs1gf-mpich, blacs1-lam, blacs1gf-lam +Description: Basic Linear Algebra Comm. Subprograms - Shared libs. for MPICH + 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 MPI. 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: libblacs-mpi-dev +Section: libdevel +Architecture: alpha amd64 armel armhf arm64 hurd-i386 i386 kfreebsd-amd64 kfreebsd-i386 mips mipsel powerpc sparc hppa m68k powerpcspe ppc64 s390x sparc64 +Depends: libblacs-openmpi1 (= ${binary:Version}) [alpha amd64 armel armhf arm64 hurd-i386 i386 kfreebsd-amd64 kfreebsd-i386 mips mipsel powerpc sparc], + libblacs-mpich1 (= ${binary:Version}) [hppa m68k powerpcspe ppc64 s390x sparc64], + mpi-default-dev, ${misc:Depends} +Replaces: blacs-mpi, blacs-mpich-dev, blacsgf-mpich-dev, blacs-lam-dev, blacsgf-lam-dev +Conflicts: blacs-mpi, blacs-mpich-dev, blacsgf-mpich-dev, blacs-lam-dev, blacsgf-lam-dev +Description: Basic Linear Algebra Comm. Subprograms - Dev. files for MPI + 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 MPI. 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: blacs-mpi-test +Section: math +Architecture: alpha amd64 armel armhf arm64 hurd-i386 i386 kfreebsd-amd64 kfreebsd-i386 mips mipsel powerpc sparc hppa m68k powerpcspe ppc64 s390x sparc64 +Depends: blacs-test-common, ${shlibs:Depends}, ${misc:Depends} +Replaces: blacs-mpich-test, blacsgf-mpich-test, blacs-lam-test, blacsgf-lam-test +Conflicts: blacs-mpich-test, blacsgf-mpich-test, blacs-lam-test, blacsgf-lam-test +Description: Basic Linear Algebra Comm. Subprograms - Test files for MPI + 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 MPI. 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 contains + test programs for the BLACS libraries. You only need these if you experience + problems with ScaLAPACK. The BLACS libraries are used as a high level + communications library for ScaLAPACK. ScaLAPACK is a parallel version of + LAPACK and is used on Beowulf type clusters. + +Package: blacs-test-common +Section: math +Architecture: all +Depends: ${misc:Depends} +Description: Test data for BLACS testers + 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 + provides test data for all BLACS packages (MPI and PVM versions). + . + Most users do not need to install this package directly because it is + installed when installing the test programs for any BLACS package. --- blacs-mpi-1.1.orig/debian/control.in +++ blacs-mpi-1.1/debian/control.in @@ -0,0 +1,115 @@ +Source: blacs-mpi +Section: devel +Priority: extra +Maintainer: Ubuntu Developers +XSBC-Original-Maintainer: Muammar El Khatib +Standards-Version: 3.9.1 +Build-Depends: debhelper (>= 7), mpi-default-dev (>= 1.0), gfortran +Homepage: http://www.netlib.org/blacs/ + +Package: libblacs-openmpi1 +Section: libs +Architecture: @OPENMPI_ARCHS@ +Depends: mpi-default-bin, ${shlibs:Depends}, ${misc:Depends} +Breaks: libblacs-mpi1 (<< 1.1-31.2) +Replaces: blacs1-mpich, blacs1gf-mpich, blacs1-lam, blacs1gf-lam, + libblacs-mpi1 (<< 1.1-31.2) +Conflicts: blacs1-mpich, blacs1gf-mpich, blacs1-lam, blacs1gf-lam +Description: Basic Linear Algebra Comm. Subprograms - Shared libs. for OpenMPI + 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 MPI. 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: libblacs-mpich1 +Section: libs +Architecture: @MPICH_ARCHS@ +Depends: mpi-default-bin, ${shlibs:Depends}, ${misc:Depends} +Breaks: libblacs-mpi1 (<< 1.1-31.2) +Replaces: blacs1-mpich, blacs1gf-mpich, blacs1-lam, blacs1gf-lam, + libblacs-mpi1 (<< 1.1-31.2) +Conflicts: blacs1-mpich, blacs1gf-mpich, blacs1-lam, blacs1gf-lam +Description: Basic Linear Algebra Comm. Subprograms - Shared libs. for MPICH + 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 MPI. 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: libblacs-mpi-dev +Section: libdevel +Architecture: @OPENMPI_ARCHS@ @MPICH_ARCHS@ +Depends: libblacs-openmpi1 (= ${binary:Version}) [@OPENMPI_ARCHS@], + libblacs-mpich1 (= ${binary:Version}) [@MPICH_ARCHS@], + mpi-default-dev, ${misc:Depends} +Replaces: blacs-mpi, blacs-mpich-dev, blacsgf-mpich-dev, blacs-lam-dev, blacsgf-lam-dev +Conflicts: blacs-mpi, blacs-mpich-dev, blacsgf-mpich-dev, blacs-lam-dev, blacsgf-lam-dev +Description: Basic Linear Algebra Comm. Subprograms - Dev. files for MPI + 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 MPI. 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: blacs-mpi-test +Section: math +Architecture: @OPENMPI_ARCHS@ @MPICH_ARCHS@ +Depends: blacs-test-common, ${shlibs:Depends}, ${misc:Depends} +Replaces: blacs-mpich-test, blacsgf-mpich-test, blacs-lam-test, blacsgf-lam-test +Conflicts: blacs-mpich-test, blacsgf-mpich-test, blacs-lam-test, blacsgf-lam-test +Description: Basic Linear Algebra Comm. Subprograms - Test files for MPI + 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 MPI. 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 contains + test programs for the BLACS libraries. You only need these if you experience + problems with ScaLAPACK. The BLACS libraries are used as a high level + communications library for ScaLAPACK. ScaLAPACK is a parallel version of + LAPACK and is used on Beowulf type clusters. + +Package: blacs-test-common +Section: math +Architecture: all +Depends: ${misc:Depends} +Description: Test data for BLACS testers + 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 + provides test data for all BLACS packages (MPI and PVM versions). + . + Most users do not need to install this package directly because it is + installed when installing the test programs for any BLACS package. --- blacs-mpi-1.1.orig/debian/copyright +++ blacs-mpi-1.1/debian/copyright @@ -0,0 +1,30 @@ +This package was debianized by Philipp Frauenfelder on +Sat, 24 Apr 1999 09:42:50 +0200 + +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.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. --- blacs-mpi-1.1.orig/debian/libblacs-mpi-dev.dirs +++ blacs-mpi-1.1/debian/libblacs-mpi-dev.dirs @@ -0,0 +1 @@ +usr/lib --- blacs-mpi-1.1.orig/debian/libblacs-mpich1.install +++ blacs-mpi-1.1/debian/libblacs-mpich1.install @@ -0,0 +1,3 @@ +libblacs-mpich.so.* usr/lib +libblacsF77init-mpich.so.* usr/lib +libblacsCinit-mpich.so.* usr/lib --- blacs-mpi-1.1.orig/debian/libblacs-openmpi1.install +++ blacs-mpi-1.1/debian/libblacs-openmpi1.install @@ -0,0 +1,3 @@ +libblacs-openmpi.so.* usr/lib +libblacsF77init-openmpi.so.* usr/lib +libblacsCinit-openmpi.so.* usr/lib --- blacs-mpi-1.1.orig/debian/rules +++ blacs-mpi-1.1/debian/rules @@ -0,0 +1,405 @@ +#! /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) + +# Read the MPI implementation provided by mpi-default-dev. +include /usr/share/mpi-default-dev/debian_defaults + +# This list of archs is maintained separately from that of the mpi-defaults +# package. If there is a mismatch between the two, the package will FTBFS. This +# is on purpose, to avoid silent breakage. See #740620 for more details. +OPENMPI_ARCHS=alpha amd64 armel armhf arm64 hurd-i386 i386 kfreebsd-amd64 kfreebsd-i386 mips mipsel powerpc sparc +MPICH_ARCHS=hppa m68k powerpcspe ppc64 s390x sparc64 + +build: build-$(ARCH_DEFAULT_MPI_IMPL) + +build-openmpi: build-stamp-openmpi + +build-lam: build-stamp-lam + +build-mpich: build-stamp-mpich + +build-mpich2: build-stamp-mpich2 + +patch-stamp: + patch -p1 < debian/blacs-mpi-implementations.patch + touch $@ + +unpatch: patch-stamp + patch -p1 -R < debian/blacs-mpi-implementations.patch + rm -f patch-stamp + +build-stamp-openmpi: patch-stamp + dh_testdir + [ -d TESTING/EXE ] || mkdir TESTING/EXE +# build the static libraries + BASEDIR=$(topdir) MPI=openmpi make mpi +# the testing binaries + cd TESTING && BASEDIR=$(topdir) \ + BTLIBS='$$(BLACSFINIT) $$(BLACSLIB) $$(BLACSFINIT) $$(MPILIB)' \ + BUILD=static MPI=openmpi make +# next is a clean + BASEDIR=$(topdir) make cleanall + cd TESTING && BASEDIR=$(topdir) make clean +# build the shared libraries + BASEDIR=$(topdir) FPIC=-fPIC MPI=openmpi make mpi + mkdir -p tmp + set -e ;\ + for i in blacs blacsF77init blacsCinit ; do \ + cd tmp ;\ + ar x ../LIB/$${i}_MPI-LINUX-0.a ;\ + mkdir -p tmp ;\ + for j in $$(find -name "*.C") ;\ + do mv $$j tmp/$$(echo $$j | sed 's,C$$,o,g') ;\ + done;\ + cd .. ;\ + gcc -shared -Wl,-soname=lib$$i-openmpi.so.1 -o lib$$i-openmpi.so.1.1 \ + -L/usr/lib/openmpi/lib/ $$(find tmp -name "*.o") -lmpi -lmpi_f77; \ + ln -fs lib$$i-openmpi.so.1.1 lib$$i-openmpi.so.1 ;\ + ln -fs lib$$i-openmpi.so.1 lib$$i-openmpi.so ;\ + rm -f tmp/tmp/* ; rmdir tmp/tmp ; rm tmp/* ;\ + done + rmdir tmp +# the testing binaries + cd TESTING && BASEDIR=$(topdir) \ + BTLIBS='-L.. -lblacsF77init-openmpi -lblacs-openmpi -lblacsF77init-openmpi $$(MPILIB)' \ + BUILD=shared MPI=openmpi make + + touch build-stamp-openmpi + +build-stamp-lam: patch-stamp + dh_testdir + [ -d TESTING/EXE ] || mkdir TESTING/EXE +# next is a clean + BASEDIR=$(topdir) make cleanall + cd TESTING && BASEDIR=$(topdir) make clean +# build the static libraries + BASEDIR=$(topdir) MPI=lam make mpi +# the testing binaries + cd TESTING && BASEDIR=$(topdir) \ + BTLIBS='$$(BLACSFINIT) $$(BLACSLIB) $$(BLACSFINIT) $$(MPILIB)' \ + BUILD=static MPI=lam make +# next is a clean + BASEDIR=$(topdir) make cleanall + cd TESTING && BASEDIR=$(topdir) make clean +# build the shared libraries + BASEDIR=$(topdir) FPIC=-fPIC MPI=lam make mpi + mkdir -p tmp + set -e ;\ + for i in blacs blacsF77init blacsCinit ; do \ + cd tmp ;\ + ar x ../LIB/$${i}_MPI-LINUX-0.a ;\ + mkdir -p tmp ;\ + for j in $$(find -name "*.C") ;\ + do mv $$j tmp/$$(echo $$j | sed 's,C$$,o,g') ;\ + done;\ + cd .. ;\ + gcc -shared -Wl,-soname=lib$$i-lam.so.1 -o lib$$i-lam.so.1.1 \ + $$(find tmp -name "*.o");\ + ln -fs lib$$i-lam.so.1.1 lib$$i-lam.so.1 ;\ + ln -fs lib$$i-lam.so.1 lib$$i-lam.so ;\ + rm -f tmp/tmp/* ; rmdir tmp/tmp ; rm tmp/* ;\ + done + rmdir tmp +# the testing binaries + cd TESTING && BASEDIR=$(topdir) \ + BTLIBS='-L.. -lblacsF77init-lam -lblacs-lam -lblacsF77init-lam $$(MPILIB)' \ + BUILD=shared MPI=lam make + + touch build-stamp-lam + +build-stamp-mpich: patch-stamp + dh_testdir + [ -d TESTING/EXE ] || mkdir TESTING/EXE +# next is a clean + BASEDIR=$(topdir) make cleanall + cd TESTING && BASEDIR=$(topdir) make clean +# build the static libraries + BASEDIR=$(topdir) MPI=mpich make mpi +# the testing binaries + cd TESTING && BASEDIR=$(topdir) \ + BTLIBS='$$(BLACSFINIT) $$(BLACSLIB) $$(BLACSFINIT) $$(MPILIB)' \ + BUILD=static MPI=mpich make +# next is a clean + BASEDIR=$(topdir) make cleanall + cd TESTING && BASEDIR=$(topdir) make clean +# build the shared libraries + BASEDIR=$(topdir) FPIC=-fPIC MPI=mpich make mpi + mkdir -p tmp + set -e ;\ + for i in blacs blacsF77init blacsCinit ; do \ + cd tmp ;\ + ar x ../LIB/$${i}_MPI-LINUX-0.a ;\ + mkdir -p tmp ;\ + for j in $$(find -name "*.C") ;\ + do mv $$j tmp/$$(echo $$j | sed 's,C$$,o,g') ;\ + done;\ + cd .. ;\ + gcc -shared -Wl,-soname=lib$$i-mpich.so.1 -o lib$$i-mpich.so.1.1 \ + $$(find tmp -name "*.o");\ + ln -fs lib$$i-mpich.so.1.1 lib$$i-mpich.so.1 ;\ + ln -fs lib$$i-mpich.so.1 lib$$i-mpich.so ;\ + rm -f tmp/tmp/* ; rmdir tmp/tmp ; rm tmp/* ;\ + done + rmdir tmp +# the testing binaries + cd TESTING && BASEDIR=$(topdir) \ + BTLIBS='-L.. -lblacsF77init-mpich -lblacs-mpich -lblacsF77init-mpich $$(MPILIB)' \ + BUILD=shared MPI=mpich make + + touch build-stamp-mpich + +build-stamp-mpich2: patch-stamp + dh_testdir + [ -d TESTING/EXE ] || mkdir TESTING/EXE +# next is a clean + BASEDIR=$(topdir) make cleanall + cd TESTING && BASEDIR=$(topdir) make clean +# build the static libraries + BASEDIR=$(topdir) MPI=mpich2 make mpi +# the testing binaries + cd TESTING && BASEDIR=$(topdir) \ + BTLIBS='$$(BLACSFINIT) $$(BLACSLIB) $$(BLACSFINIT) $$(MPILIB)' \ + BUILD=static MPI=mpich2 make +# next is a clean + BASEDIR=$(topdir) make cleanall + cd TESTING && BASEDIR=$(topdir) make clean +# build the shared libraries + BASEDIR=$(topdir) FPIC=-fPIC MPI=mpich2 make mpi + mkdir -p tmp + set -e ;\ + for i in blacs blacsF77init blacsCinit ; do \ + cd tmp ;\ + ar x ../LIB/$${i}_MPI-LINUX-0.a ;\ + mkdir -p tmp ;\ + for j in $$(find -name "*.C") ;\ + do mv $$j tmp/$$(echo $$j | sed 's,C$$,o,g') ;\ + done;\ + cd .. ;\ + gcc -shared -Wl,-soname=lib$$i-mpich2.so.1 -lmpich -o lib$$i-mpich2.so.1.1 \ + $$(find tmp -name "*.o");\ + ln -fs lib$$i-mpich2.so.1.1 lib$$i-mpich2.so.1 ;\ + ln -fs lib$$i-mpich2.so.1 lib$$i-mpich2.so ;\ + rm -f tmp/tmp/* ; rmdir tmp/tmp ; rm tmp/* ;\ + done + rmdir tmp +# the testing binaries + cd TESTING && BASEDIR=$(topdir) \ + BTLIBS='-L.. -lblacsF77init-mpich2 -lblacs-mpich2 -lblacsF77init-mpich2 $$(MPILIB)' \ + BUILD=shared MPI=mpich2 make + + touch build-stamp-mpich2 + +clean: unpatch + dh_testdir + dh_testroot + rm -f build-stamp-* install-stamp-* + BASEDIR=$(topdir) make cleanall + cd TESTING && BASEDIR=$(topdir) make clean + cd LIB && rm -f *.a + rm -f *so* + rm -rf TESTING/EXE + dh_clean + + { \ + echo "# This file is autogenerated. DO NOT EDIT!" ; \ + echo "#" ; \ + echo "# Modifications should be made to debian/control.in instead." ; \ + echo "# This file is regenerated automatically in the clean target." ; \ + echo ; \ + sed "s/@OPENMPI_ARCHS@/$(OPENMPI_ARCHS)/g;s/@MPICH_ARCHS@/$(MPICH_ARCHS)/g;" debian/control.in ; } \ + > debian/control + +install: install-$(ARCH_DEFAULT_MPI_IMPL) + +install-openmpi: install-stamp-openmpi + +install-lam: install-stamp-lam + +install-mpich: install-stamp-mpich + +install-mpich2: install-stamp-mpich2 + +install-stamp-openmpi: build-stamp-openmpi + dh_testdir + dh_testroot + dh_prep + dh_installdirs -v -a + + # The shared library are installed via debian/*.install, to avoid + # creating an empty package if default MPI implementation changes on + # the arch + dh_install + + set -e ;\ + for i in blacs blacsF77init blacsCinit ; do \ + cp -a lib$$i-openmpi.so \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/ ;\ + done + + set -e ;\ + for i in shared static ; do \ + install TESTING/EXE/xCbtest_MPI-LINUX-0-$$i-openmpi \ + `pwd`/debian/blacs-mpi-test/usr/lib/blacs/cblacs_test_$$i-openmpi ;\ + install TESTING/EXE/xFbtest_MPI-LINUX-0-$$i-openmpi \ + `pwd`/debian/blacs-mpi-test/usr/lib/blacs/fblacs_test_$$i-openmpi ;\ + done + + set -e ;\ + install LIB/blacsCinit_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacsCinit-openmpi.a + install LIB/blacsF77init_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacsF77init-openmpi.a + install LIB/blacs_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacs-openmpi.a + + touch install-stamp-openmpi + +install-stamp-lam: build-stamp-lam + dh_testdir + dh_testroot + dh_prep + dh_installdirs -v -a + + set -e ;\ + for i in blacs blacsF77init blacsCinit ; do \ + cp -a lib$$i-lam.so.* \ + `pwd`/debian/libblacs-mpi1/usr/lib/ ;\ + cp -a lib$$i-lam.so \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/ ;\ + done + + set -e ;\ + for i in shared static ; do \ + install TESTING/EXE/xCbtest_MPI-LINUX-0-$$i-lam \ + `pwd`/debian/blacs-mpi-test/usr/lib/blacs/cblacs_test_$$i-lam ;\ + install TESTING/EXE/xFbtest_MPI-LINUX-0-$$i-lam \ + `pwd`/debian/blacs-mpi-test/usr/lib/blacs/fblacs_test_$$i-lam ;\ + done + + set -e ;\ + install LIB/blacsCinit_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacsCinit-lam.a + install LIB/blacsF77init_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacsF77init-lam.a + install LIB/blacs_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacs-lam.a + + touch install-stamp-lam + +install-stamp-mpich: build-stamp-mpich + dh_testdir + dh_testroot + dh_prep + dh_installdirs -v -a + + # The shared library are installed via debian/*.install, to avoid + # creating an empty package if default MPI implementation changes on + # the arch + dh_install + + set -e ;\ + for i in blacs blacsF77init blacsCinit ; do \ + cp -a lib$$i-mpich.so \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/ ;\ + done + + set -e ;\ + for i in shared static ; do \ + install TESTING/EXE/xCbtest_MPI-LINUX-0-$$i-mpich \ + `pwd`/debian/blacs-mpi-test/usr/lib/blacs/cblacs_test_$$i-mpich ;\ + install TESTING/EXE/xFbtest_MPI-LINUX-0-$$i-mpich \ + `pwd`/debian/blacs-mpi-test/usr/lib/blacs/fblacs_test_$$i-mpich ;\ + done + + set -e ;\ + install LIB/blacsCinit_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacsCinit-mpich.a + install LIB/blacsF77init_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacsF77init-mpich.a + install LIB/blacs_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacs-mpich.a + + touch install-stamp-mpich + +install-stamp-mpich2: build-stamp-mpich2 + dh_testdir + dh_testroot + dh_prep + dh_installdirs -v -a + + set -e ;\ + for i in blacs blacsF77init blacsCinit ; do \ + cp -a lib$$i-mpich2.so.* \ + `pwd`/debian/libblacs-mpi1/usr/lib/ ;\ + cp -a lib$$i-mpich2.so \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/ ;\ + done + + set -e ;\ + for i in shared static ; do \ + install TESTING/EXE/xCbtest_MPI-LINUX-0-$$i-mpich2 \ + `pwd`/debian/blacs-mpi-test/usr/lib/blacs/cblacs_test_$$i-mpich2 ;\ + install TESTING/EXE/xFbtest_MPI-LINUX-0-$$i-mpich2 \ + `pwd`/debian/blacs-mpi-test/usr/lib/blacs/fblacs_test_$$i-mpich2 ;\ + done + + set -e ;\ + install LIB/blacsCinit_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacsCinit-mpich2.a + install LIB/blacsF77init_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacsF77init-mpich2.a + install LIB/blacs_MPI-LINUX-0.a \ + `pwd`/debian/libblacs-mpi-dev/usr/lib/libblacs-mpich2.a + + touch install-stamp-mpich2 + +binary-arch: build install + dh_testdir -a + dh_testroot -a + dh_installdocs -a README + dh_installexamples -a + dh_installman -a + dh_installchangelogs -a + dh_link -a + dh_compress -a + dh_fixperms -a + dh_strip -a + dh_makeshlibs -a + dh_installdeb -a + dh_shlibdeps -Lblacs-mpi-test -ldebian/blacs-mpi-test/usr/lib/blacs/ -Llibblacs-mpi-dev -ldebian/libblacs-mpi-dev/usr/lib/ \ + LD_LIBRARY_PATH="/usr/lib/openmpi/lib$${LD_LIBRARY_PATH:+:}$$LD_LIBRARY_PATH" -Llibblacs-mpi1 -l/usr/lib/openmpi/lib/ + dh_gencontrol -a + dh_md5sums -a + dh_builddeb -a + +binary-indep: + dh_testdir -i + dh_testroot -i + dh_installdirs -i + dh_installdocs -i README + dh_installchangelogs -i + + cd TESTING && BASEDIR=$(topdir) make dat + set -e ;\ + for i in $$(find TESTING/EXE -name "*.dat"); do \ + install -m 644 $$i `pwd`/debian/blacs-test-common/usr/lib/blacs ;\ + done + + dh_link -i + dh_compress -i + dh_fixperms -i + dh_installdeb -i + dh_gencontrol -i + dh_md5sums -i + dh_builddeb -i + +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 --- blacs-mpi-1.1.orig/debian/source/format +++ blacs-mpi-1.1/debian/source/format @@ -0,0 +1 @@ +1.0