diff --git a/.travis.yml b/.travis.yml index c5e539603c..70f8bc5402 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,7 +28,7 @@ matrix: - { os: linux, env: COMPILER=gnu USE_CMAKE=0 BUILD_FLAGS="-openmp" OPT=openmp OMP_NUM_THREADS=4 BUILD_TYPE=install TEST_TYPE=test.showerrors } - { os: linux, env: COMPILER=gnu USE_CMAKE=0 BUILD_FLAGS="-mpi" DO_PARALLEL="mpiexec -n 2" BUILD_TYPE=install TEST_TYPE=test.showerrors } - { os: osx, env: COMPILER=clang USE_CMAKE=0 BUILD_FLAGS="-macAccelerate --with-fftw3=/usr/local --with-netcdf=/usr/local -noarpack" BUILD_TYPE=install TEST_TYPE=test.showerrors } - - { os: linux, env: COMPILER=gnu USE_CMAKE=0 BUILD_FLAGS="-openmp -shared" OPT=openmp OMP_NUM_THREADS=1 BUILD_TYPE=libcpptraj TEST_TYPE=test.libcpptraj } + - { os: linux, env: COMPILER=gnu USE_CMAKE=0 BUILD_FLAGS="-openmp -shared -fftw3" OPT=openmp OMP_NUM_THREADS=1 BUILD_TYPE=libcpptraj TEST_TYPE=test.libcpptraj } - { os: linux, env: COMPILER=GNU USE_CMAKE=1 BUILD_FLAGS="-DOPENMP=TRUE" OMP_NUM_THREADS=4 TEST_TYPE=test.showerrors} - { os: osx, osx_image: xcode9.2, env: COMPILER=CLANG USE_CMAKE=1 BUILD_FLAGS="" TEST_TYPE=test.showerrors} @@ -64,10 +64,10 @@ install: else if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then export DYLD_FALLBACK_LIBRARY_PATH=$HOME/lib:$DYLD_FALLBACK_LIBRARY_PATH; - ./configure $BUILD_FLAGS CFLAGS="-lnetcdf -lfftw3" $COMPILER; + ./configure $BUILD_FLAGS $COMPILER; else export LD_LIBRARY_PATH=$HOME/lib:$LD_LIBRARY_PATH; - ./configure $BUILD_FLAGS CFLAGS="-lnetcdf -lfftw3" $COMPILER; + ./configure $BUILD_FLAGS $COMPILER; fi; make -j2 $BUILD_TYPE ; fi diff --git a/configure b/configure index 4760febedb..e68aa3d2bc 100755 --- a/configure +++ b/configure @@ -1,28 +1,36 @@ #!/bin/bash -# CPPTRAJ standalone configure script +# CPPTRAJ standalone configure script. # Daniel R. Roe # 2010-11-18 -# Simple script to set compiler vars. Create config.h, which will be used -# by src/Makefile. +# Rewritten 2018-01-25 (getting old...) +# This script will determine compiler and linker flags based on +# desired user-specified options. Generates config.h, which is +# used by src/Makefile. -# Print help message +#------------------------------------------------------------------------------- +# Print simple help message UsageSimple() { echo "Usage: ./configure [gnu | intel | pgi | clang | cray]" echo " OPTIONS:" echo " --help : Display this message." - echo " -openmp : Use openmp for parallelization of certain routines." + echo " -openmp : Use OpenMP for parallelization of certain routines." echo " -mpi : Use mpicc/mpicxx to compile." echo " -intelmpi : Use mpiicc/mpiicpc to compile." + echo " -cuda : Enable support for CUDA. See SHADER_MODEL in --full-help for more info." echo " -cray : Use cray compiler wrappers (cc/CC/ftn)." echo " -amberlib : Use BLAS/ARPACK/LAPACK/NetCDF libraries from \$AMBERHOME" echo " --full-help : Display additional options." echo "" } +#------------------------------------------------------------------------------- +# Print more detailed options UsageFull() { - echo " ADDITIONAL OPTIONS:" + UsageSimple + echo " ADDITIONAL OPTIONS" echo " -debug : Turn on compiler debugging info." echo " -noopt : Do not use optimized compiler flags." + echo " -noc++11 : Disable C++11 support." echo " -d : Turn on compiler debug info and disable optimization (i.e. -debug -noopt)." echo " -timer : Enable additional timing info." echo " -debugon : Add -DDEBUG flag to activate additional internal debugging." @@ -30,33 +38,19 @@ UsageFull() { echo " -shared : Configure for generating libcpptraj (implies -nosanderlib)." echo " -fftw3 : Use FFTW instead of pubfft for FFT." echo " -windows : Set up for use with MinGW compilers for a native Windows build" - echo "" - echo " LIBRARY LINKING OPTIONS:" - echo " --with-netcdf=" - echo " --with-pnetcdf= (PNETCDF is needed for NetCDF parallel trajectory processing)" - echo " --with-zlib=" - echo " --with-bzlib=" - echo " --with-blas=" - echo " --with-lapack=" - echo " --with-arpack=" - echo " --with-fftw3=" - echo " --with-readline=" - echo " --with-sanderlib=" -# echo " --with-hdf5=" + echo " LIBRARY OPTIONS" + echo " - : Enable library." + echo " --with-= : Use library in specified directory." + echo " -no : Disable library." + echo " Libraries: netcdf pnetcdf zlib bzlib blas lapack arpack fftw3 readline sanderlib xdrfile" + echo " Note: pnetcdf is needed for writing NetCDF trajectories with MPI." + echo " LINKING OPTIONS" echo " -static : Use static linking." echo " -libstatic : Use static linking only for specified libraries." - echo " -openblas : Use OpenBLAS (with LAPACK) instead of separate BLAS/LAPACK" + echo " -mkl : Use Intel MKL for BLAS/LAPACK (requires MKL_HOME/MKLROOT set)." + echo " -openblas : Use OpenBLAS for BLAS/LAPACK/ARPACK (may require '--with-blas')" echo " -macAccelerate : Use Accelerate framework for BLAS/LAPACK" echo " -libsci : Use Cray LibSci for BLAS/LAPACK" - echo " -mkl : Use Intel MKL for BLAS/LAPACK (requires MKL_HOME/MKLROOT set)." - echo " -nobzlib : Do not use libbz2 (bzip2)" - echo " -nozlib : Do not use zlib (gzip/zip)" - echo " -nonetcdf : Do not use NetCDF" - echo " -nomathlib : Do not include routines which require LAPACK or BLAS" - echo " -noarpack : Do not include routines which require ARPACK" - echo " -noreadline : Do not include support for readline in the interpreter" - echo " -nosanderlib : Do not try to link to the sander API even if present" - echo "" echo " ENVIRONMENT VARIABLES (can also be passed to configure as =):" echo " CXX : Name of the C++ compiler." echo " CC : Name of the C compiler." @@ -68,131 +62,356 @@ UsageFull() { echo " CFLAGS : Flags to pass to the C compiler." echo " FFLAGS : Flags to pass to the Fortran compiler." echo " LDFLAGS : Flags to pass to the linker." + echo " NVCC : Name of the nvcc compiler." + echo " NVCCFLAGS : Flags to pass to the nvcc compiler." echo " DBGFLAGS : Any additional flags to pass to all compilers." echo " SHADER_MODEL : (-cuda) Should be set to 'sm_XX', where XX is CUDA compute architecture." - echo "" + echo " SM6.2 = GP10B" + echo " SM6.1 = GP106 = GTX-1070, GP104 = GTX-1080, GP102 = Titan-X[P]" + echo " SM6.0 = GP100 / P100 = DGX-1" + echo " SM5.3 = GM200 [Grid] = M60, M40?" + echo " SM5.2 = GM200 = GTX-Titan-X, M6000 etc." + echo " SM5.0 = GM204 = GTX980, 970 etc" + echo " SM3.7 = GK210 = K80" + echo " SM3.5 = GK110 = K20[x], K40, GTX780, GTX-Titan, GTX-Titan-Black, GTX-Titan-Z" + echo " SM3.0 = GK104 = K10, GTX680, 690 etc." + echo " SM2.0 = All GF variants = C2050, 2075, M2090, GTX480, GTX580 etc." echo " EXPERIMENTAL OPTIONS:" - echo " -profile : Use Gnu compiler profiling (>= V4.5)*" - echo " -gprofile : Use Gnu compiler GLIBC profiling (>= V4.5)*" - echo " -vtune : Enable options for use with Intel Vtune" - echo " -single-ensemble : Enable support for reading/writing single ensemble trajectories." - echo " -cuda : Enable support for CUDA. Requires SHADER_MODEL be set." + echo " --compile-verbose : Turn on compile details." + echo " -profile : Use Gnu compiler profiling (>= V4.5)*" + echo " -gprofile : Use Gnu compiler GLIBC profiling (>= V4.5)*" + echo " -vtune : Enable options for use with Intel Vtune" + echo " -single-ensemble : Enable support for reading/writing single ensemble trajectories." echo "" echo "*NOTE: -profile and -gprofile are mutually exclusive." echo "" } -# CompileError "Compile Line" -# Compile error message -CompileError() { - echo " Error: Unable to compile using:" - echo " $1" - echo " Please check your compiler settings or configure flags. Error follows:" - echo " --------------------" - cat compile.err - echo " --------------------" - echo "" +# ----- Script variables ------------------------------------------------------- +COMPILERS='' # User-specified compiler suite to use. +FLINK='' # Flag for linking in Fortran code +REQUIRES_FLINK=0 # If 1 FLINK flag required during link phase +C11FLAG='' # Flag for compiling C++11 code +C11_SUPPORT='yes' # Support C++11 code +SHARED_SUFFIX='' # Suffix for shared libraries +DBFLAG='' # Flag for turning on compiler debug symbols +DIRECTIVES='' # Common compiler directives +INCLUDE='' # Library header include line +SFX='' # Binary suffix +EXE='' # Binary executable suffix + +# ----- Configure options ------------------------ +COMPILE_VERBOSE=0 # 1 = show details during compile +USE_MPI=0 # 0 = no MPI, 1 = mpicc etc, 2 = mpiicc etc +USE_OPENMP=0 # 0 = no OpenMP, 1 = OpenMP +USE_CUDA=0 # 0 = no CUDA, 1 = CUDA +USE_OPT=1 # 0 = no optimization, 1 = use compiler optimizations. +BLAS_TYPE='other' # other=normal BLAS, mkl, libsci (cray) etc +MKL_TYPE='mkl' # mkl = -mkl for Intel compilers, line = link-line advisor style +USE_DEBUG=0 # 0 = no debug info, 1 = enable compiler debug info +USE_STATIC=0 # 0 = dynamic linking, 1 = static linking, 2 = static link for specified libraries +USE_SHARED=0 # 1 = Use flag for position-independent code (required for libcpptraj) +USE_PROFILE=0 # 0 = no profiling, 1 = C++ profiling, 2 = GLIBC profiling, 3 = Intel Vtune +USE_AMBERLIB=0 # 1 = Use AMBERHOME to fill in NetCDF/BLAS/LAPACK/ARPACK as needed + +USE_SINGLEENSEMBLE=0 # Enable support for single ensemble trajectories +USE_CPPTRAJDEBUG=0 # Enable internal cpptraj debug flags + +CLEAN='yes' # yes = clean after configure, no = do not +PERFORM_CHECKS='yes' # yes = Check compilers/libraries, no = do not + +# Flags for large file support +LFS='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' + +# Install locations +CPPTRAJHOME='' +CPPTRAJBIN='' +CPPTRAJLIB='' + +# ----- External Libraries ----------------------- +# Total number of external libraries +NLIB=13 +# Library indices +# Original: FFT ARPACK LAPACK BLAS NETCDF PARANC BZIP ZIP READLINE XDRFILE +LNETCDF=0 +LPARANC=1 # Parallel NetCDF +LBZIP=2 +LZIP=3 +LARPACK=4 +LLAPACK=5 +LBLAS=6 +LFFTW3=7 +LREADLINE=8 +LXDRFILE=9 +LSANDER=10 +LTIMER=11 +LCUDA=12 + +# LIB_STAT = Library status: +# off : Do not use library. +# enabled : Try to use library. +# specified : Library location has been specified. +# amberopt : Use library from AMBERHOME - optional. +# bundled : Use bundled version of library. +LIB_STAT[$LNETCDF]='enabled' # off, enabled, specified, amberopt, bundled +LIB_CKEY[$LNETCDF]='netcdf' # Command-line key for '-', '--with-' and '-no' +LIB_HOME[$LNETCDF]='' # Library home directory (-L) +LIB_FLAG[$LNETCDF]='-lnetcdf' # Library linker flag +LIB_STTC[$LNETCDF]='libnetcdf.a' # Expected static location relative to home +LIB_D_ON[$LNETCDF]='-DBINTRAJ' # Directive if library on +LIB_DOFF[$LNETCDF]='' # Directive if library off +LIB_LINK[$LNETCDF]='dynamic' # How to link the library +LIB_TYPE[$LNETCDF]='ld' # ld = LDFLAGS, cpp = cpptraj, blank = special + +LIB_STAT[$LPARANC]='off' +LIB_CKEY[$LPARANC]='pnetcdf' +LIB_HOME[$LPARANC]='' +LIB_FLAG[$LPARANC]='-lpnetcdf' +LIB_STTC[$LPARANC]='libpnetcdf.a' +LIB_D_ON[$LPARANC]='-DHAS_PNETCDF' +LIB_DOFF[$LPARANC]='' +LIB_TYPE[$LPARANC]='ld' + +LIB_STAT[$LBZIP]='enabled' +LIB_CKEY[$LBZIP]='bzlib' +LIB_HOME[$LBZIP]='' +LIB_FLAG[$LBZIP]='-lbz2' +LIB_STTC[$LBZIP]='libbz2.a' +LIB_D_ON[$LBZIP]='-DHASBZ2' +LIB_DOFF[$LBZIP]='' +LIB_TYPE[$LBZIP]='ld' + +LIB_STAT[$LZIP]='enabled' +LIB_CKEY[$LZIP]='zlib' +LIB_HOME[$LZIP]='' +LIB_FLAG[$LZIP]='-lz' +LIB_STTC[$LZIP]='libz.a' +LIB_D_ON[$LZIP]='-DHASGZ' +LIB_DOFF[$LZIP]='' +LIB_TYPE[$LZIP]='ld' + +LIB_STAT[$LBLAS]='enabled' +LIB_CKEY[$LBLAS]='blas' +LIB_HOME[$LBLAS]='' +LIB_FLAG[$LBLAS]='-lblas' +LIB_STTC[$LBLAS]='libblas.a' +LIB_D_ON[$LBLAS]='' +LIB_DOFF[$LBLAS]='-DNO_MATHLIB' +LIB_TYPE[$LBLAS]='cpp' + +LIB_STAT[$LLAPACK]='enabled' +LIB_CKEY[$LLAPACK]='lapack' +LIB_HOME[$LLAPACK]='' +LIB_FLAG[$LLAPACK]='-llapack' +LIB_STTC[$LLAPACK]='liblapack.a' +LIB_D_ON[$LLAPACK]='' +LIB_DOFF[$LLAPACK]='' +LIB_TYPE[$LLAPACK]='cpp' + +LIB_STAT[$LARPACK]='bundled' +LIB_CKEY[$LARPACK]='arpack' +LIB_HOME[$LARPACK]='arpack' +LIB_FLAG[$LARPACK]='-larpack' +LIB_STTC[$LARPACK]='libarpack.a' +LIB_D_ON[$LARPACK]='' +LIB_DOFF[$LARPACK]='-DNO_ARPACK' +LIB_TYPE[$LARPACK]='cpp' + +LIB_STAT[$LFFTW3]='off' +LIB_CKEY[$LFFTW3]='fftw3' +LIB_HOME[$LFFTW3]='' +LIB_FLAG[$LFFTW3]='-lfftw3' +LIB_STTC[$LFFTW3]='libfftw3.a' +LIB_D_ON[$LFFTW3]='-DFFTW_FFT' +LIB_DOFF[$LFFTW3]='' +LIB_TYPE[$LFFTW3]='cpp' + +LIB_STAT[$LREADLINE]='bundled' +LIB_CKEY[$LREADLINE]='readline' +LIB_HOME[$LREADLINE]='readline' +LIB_FLAG[$LREADLINE]='-lreadline' +LIB_STTC[$LREADLINE]='libreadline.a' +LIB_D_ON[$LREADLINE]='' +LIB_DOFF[$LREADLINE]='-DNO_READLINE' +LIB_TYPE[$LREADLINE]='' + +LIB_STAT[$LXDRFILE]='bundled' +LIB_CKEY[$LXDRFILE]='xdrfile' +LIB_HOME[$LXDRFILE]='xdrfile' +LIB_FLAG[$LXDRFILE]='-lxdrfile' +LIB_STTC[$LXDRFILE]='libxdrfile.a' +LIB_D_ON[$LXDRFILE]='' +LIB_DOFF[$LXDRFILE]='-DNO_XDRFILE' +LIB_TYPE[$LXDRFILE]='ld' + +LIB_STAT[$LSANDER]='amberopt' +LIB_CKEY[$LSANDER]='sanderlib' +LIB_HOME[$LSANDER]='' +LIB_FLAG[$LSANDER]='-lsander' +LIB_STTC[$LSANDER]='' +LIB_D_ON[$LSANDER]='-DUSE_SANDERLIB' +LIB_DOFF[$LSANDER]='' +LIB_TYPE[$LSANDER]='cpp' + +LIB_STAT[$LTIMER]='off' +LIB_CKEY[$LTIMER]='timer' +LIB_FLAG[$LTIMER]='-lrt' +LIB_D_ON[$LTIMER]='-DTIMER' +LIB_TYPE[$LTIMER]='ld' + +LIB_STAT[$LCUDA]='off' +LIB_CKEY[$LCUDA]='cuda' +LIB_HOME[$LCUDA]='' +LIB_FLAG[$LCUDA]='-lcuda -lcudart' +LIB_STTC[$LCUDA]='' +LIB_D_ON[$LCUDA]='-DCUDA' +LIB_DOFF[$LCUDA]='' +LIB_TYPE[$LCUDA]='cpp' + +for ((i=0; i < $NLIB; i++)) ; do + LIB_LINK[$i]='dynamic' +done + +#------------------------------------------------------------------------------- +# Print message to stderr and exit. +Err() { + echo "Error: $*" > /dev/stderr exit 1 } -# Test that OpenMP works -TestOpenMP() { - if [[ $USEOPENMP -eq 1 ]] ; then - cat > testp.cpp < -#include -int main() { - int nthreads; -# pragma omp parallel - { - if (omp_get_thread_num() == 0) - nthreads = omp_get_num_threads(); - } - printf("%i threads Testing\n", nthreads); - return 0; -} -#endif -EOF - $CXX -o testp $OMPFLAGS testp.cpp > /dev/null 2> compile.err - ERR=$? - if [[ $ERR -eq 0 ]] ; then - ./testp | grep "Testing" > /dev/null - ERR=$? +#------------------------------------------------------------------------------- +# Check for '--with' and '-no' library keys. +CheckLibraryKeys() { + for ((i=0; i < $NLIB; i++)) ; do + LKEY="-"${LIB_CKEY[$i]} + if [ "$1" = "$LKEY" ] ; then + LIB_STAT[$i]='enabled' + echo " ${LIB_CKEY[$i]} enabled." + return 0 fi - if [[ $ERR -ne 0 ]] ; then - echo "Error: OpenMP not supported for compiler $CXX" - cat compile.err - exit 1 + LKEY="--with-"${LIB_CKEY[$i]} + if [ "$1" = "$LKEY" ] ; then + LIB_HOME[$i]=$2 + LIB_STAT[$i]='specified' + echo " ${LIB_CKEY[$i]} specified: $2" + return 0 fi - /bin/rm -f testp testp.cpp compile.err - fi + LKEY="-no"${LIB_CKEY[$i]} + if [ "$1" = "$LKEY" ] ; then + LIB_STAT[$i]='off' + echo " ${LIB_CKEY[$i]} disabled." + return 0 + fi + done + return 1 } -# TestCxxProgram "TestName" "Lib" -# Test compile test program testp.cpp -TestCxxProgram() { - echo "$1" - COMPILELINE="$CXX $INCLUDE -o testp testp.cpp $2" +#------------------------------------------------------------------------------- +# Test compile and run a program. +# ARGS: [silent|quiet] [] +TestProgram() { + if [ "$1" = 'quiet' ] ; then + silent=2 + shift + elif [ "$1" = 'silent' ] ; then + silent=1 + shift + else + silent=0 + fi + desc="$1" + comp="$2" + args="$3" + file="$4" + link="$5 $LDFLAGS" + if [ $silent -ne 2 ] ; then echo -n "$desc: " ; fi + COMPILELINE="$comp $args -o testp $file $link" + #echo "COMPILE: $COMPILELINE" #DEBUG $COMPILELINE > /dev/null 2> compile.err - ./testp | grep "Testing" > /dev/null - status=$? - if [[ $status -gt 0 ]] ; then - CompileError "$COMPILELINE" + if [ $? -ne 0 ] ; then + if [ $silent -eq 0 ] ; then + echo "" + echo "Compile failed: $COMPILELINE" > /dev/stderr + echo "Error follows:" > /dev/stderr + cat compile.err > /dev/stderr + exit 1 + else + rm compile.err + return 1 + fi + fi + ./testp > /dev/null + if [ $? -ne 0 ] ; then + echo "" + echo "Program failed, compiled with: $COMPILELINE" > /dev/stderr + exit 1 fi - /bin/rm -f testp.cpp testp compile.err - echo " OK" + if [ $silent -ne 2 ] ; then echo "OK" ; fi + rm -f $file testp compile.err + return 0 } +# ===== LIBRARY TESTS ========================================================== TestBzlib() { - if [[ ! -z $BZLIB ]] ; then - cat > testp.cpp < testp.cpp < #include "bzlib.h" int main() { BZFILE *bfile; bfile=NULL; printf("Testing\n"); return 0; } EOF - TestCxxProgram "Checking BZLIB" "$BZLIB" - fi + TestProgram " Checking BZLIB" "$CXX" "$CXXFLAGS ${LIB_INCL[$LBZIP]}" testp.cpp "${LIB_FLAG[$LBZIP]}" } TestZlib() { - if [[ ! -z $ZLIB ]] ; then - cat > testp.cpp < testp.cpp < #include "zlib.h" int main() { gzFile gfile; gfile=NULL; printf("Testing\n"); return 0; } EOF - TestCxxProgram "Checking ZLIB" "$ZLIB" - fi + TestProgram " Checking ZLIB" "$CXX" "$CXXFLAGS ${LIB_INCL[$LZIP]}" testp.cpp "${LIB_FLAG[$LZIP]}" } TestNetcdf() { - if [[ ! -z $NETCDFLIB ]] ; then - cat > testp.cpp < testp.cpp < #include "netcdf.h" void unused() {int ncid; nc_open("foo.nc", 0, &ncid);} int main() { printf("Testing\n"); printf("%s\n",nc_strerror(0)); return 0; } EOF - TestCxxProgram "Checking NetCDF" "$NETCDFLIB" - fi + TestProgram " Checking NetCDF" "$CXX" "$CXXFLAGS ${LIB_INCL[$LNETCDF]}" testp.cpp "${LIB_FLAG[$LNETCDF]}" } TestPnetcdf() { - if [[ ! -z $PNETCDFLIB ]] ; then - cat > testp.cpp < testp.cpp < #include void unused() {int ncid; ncmpi_open(MPI_COMM_WORLD, "foo.nc", NC_NOWRITE, MPI_INFO_NULL, &ncid);} int main() { printf("Testing\n"); printf("%s\n",ncmpi_strerror(0)); return 0; } EOF - TestCxxProgram "Checking Parallel NetCDF" "$PNETCDFLIB" - fi + TestProgram " Checking Parallel NetCDF" "$CXX" "$CXXFLAGS ${LIB_INCL[$LPARANC]}" testp.cpp "${LIB_FLAG[$LPARANC]}" } +DetermineFlink() { + desc="$1" + flibs="$2" + if [ $REQUIRES_FLINK -eq 0 ] ; then + # Try without FLINK + TestProgram quiet "$desc" "$CXX" "$CXXFLAGS" testp.cpp "$flibs" + if [ $? -eq 1 ] ; then + # That failed. Try with FLINK + TestProgram "$desc" "$CXX" "$CXXFLAGS" testp.cpp "$flibs $FLINK" + REQUIRES_FLINK=1 + else + # That worked. Print OK." + echo "$desc: OK" + fi + else + # FLINK already present + TestProgram "$desc" "$CXX" "$CXXFLAGS" testp.cpp "$flibs $FLINK" + fi +} + TestMathlib() { - if [[ ! -z $BLAS || $USELIBSCI -eq 1 || $USEMKL -eq 1 ]] ; then # ASSUME LAPACK also defined - cat > testp.cpp < testp.cpp < extern "C" { void dsyev_(char*, char*, int&, double*, int&, double*,double*,int&,int&); @@ -211,13 +430,11 @@ int main() { printf("Testing\n"); return 0; } EOF - TestCxxProgram "Checking LAPACK/BLAS" "$LAPACK $BLAS $MKLLIB $FLIBS" - fi + DetermineFlink " Checking LAPACK/BLAS" "${LIB_FLAG[$LLAPACK]} ${LIB_FLAG[$LBLAS]}" } TestArpack() { - if [[ ! -z $ARPACK ]] ; then # Assume BLAS and LAPACK also defined - cat > testp.cpp < testp.cpp < extern "C" { void dsaupd_(int&, char&, int&, char*, int&, double&, double*, @@ -234,13 +451,11 @@ int main() { printf("Testing\n"); return 0; } EOF - TestCxxProgram "Checking ARPACK" "$ARPACK $LAPACK $BLAS $MKLLIB $FLIBS" - fi + DetermineFlink " Checking ARPACK" "${LIB_FLAG[$LARPACK]} ${LIB_FLAG[$LLAPACK]} ${LIB_FLAG[$LBLAS]}" } TestFFTW3() { - if [[ -z $FFT_DEPEND && ! -z $FFT_LIB ]] ; then - cat > testp.cpp < testp.cpp < #include int main() { @@ -250,37 +465,39 @@ int main() { printf("Testing\n"); return 0; } EOF - TestCxxProgram "Checking FFTW3" "$FFT_LIB" - fi + TestProgram " Checking FFTW3" "$CXX" "$CXXFLAGS ${LIB_INCL[$LFFTW3]}" testp.cpp "${LIB_FLAG[$LFFTW3]}" } -# This test is different than the others in that it is used to dynamically -# check whether the library is usable and set flags accordingly. -TestSanderlib() { - SL_ERR=0 - if [ "$USE_SANDERLIB" -gt 0 ] ; then - echo "Checking availability of the SANDER API from AmberTools" - if [[ -z $SANDERLIB_HOME ]] ; then - if [[ -z $AMBERHOME ]] ; then - echo "Warning: Compilation with the SANDER API requires AMBERHOME to be set" - echo " if '--with-sanderlib' not specified." - SL_ERR=1 - else - SANDERLIB_HOME=$AMBERHOME - fi - fi - if [[ $SL_ERR -eq 0 ]] ; then - if [ "$SKIP_CHECKS" = 'no' -a ! -f "$SANDERLIB_HOME/lib/libsander$SHARED_SUFFIX" ] ; then - echo "Warning: $SANDERLIB_HOME/lib/libsander$SHARED_SUFFIX not present." - SL_ERR=1 - else - SANDERINC="-I$SANDERLIB_HOME/include" - SANDERLIB="-L$SANDERLIB_HOME/lib -lsander" - if [ "$SKIP_CHECKS" = 'no' ] ; then - echo " Using SANDER API from $SANDERLIB_HOME" - # Test that libsander can be linked - cat > testp.cpp < testp.cpp < +#include +static char *line_read = (char *)NULL; +// Do not want to actually run this so leave outside main +void Unused() { line_read = readline(""); } +int main() { return 0; } +EOF + TestProgram " Checking Readline" "$CXX" "$CXXFLAGS ${LIB_INCL[$LREADLINE]}" testp.cpp "${LIB_FLAG[$LREADLINE]}" +} + +TestXdrfile() { + cat > testp.cpp < +#include +XDRFILE* file; +bool Unused(const char* fname, int& natoms) { + if ( read_xtc_natoms( (char*)fname, &natoms ) != exdrOK ) + return false; + xdr_seek(file, 0, SEEK_SET); + return true; +} +int main() { return 0; } +EOF + TestProgram " Checking Xdrfile" "$CXX" "$CXXFLAGS ${LIB_INCL[$LXDRFILE]}" testp.cpp "${LIB_FLAG[$LXDRFILE]}" +} + +TestSanderlib() { + cat > testp.cpp < /dev/null 2> compile.err - SL_ERR=$? - if [[ $SL_ERR -eq 0 ]] ; then - ./testp | grep "Testing" > /dev/null 2>> compile.err - SL_ERR=$? - fi - if [[ $SL_ERR -ne 0 ]] ; then - echo "Warning: Compilation with the SANDER API failed. Error follows:" - echo " --------------------" - cat compile.err - echo " --------------------" - if [ "$USE_SANDERLIB" -eq 2 ] ; then - exit 1 - fi - else - echo " OK" - CPPTRAJ_LIB=$CPPTRAJ_LIB" $SANDERLIB" - CXXFLAGS=$CXXFLAGS" $SANDERINC -DUSE_SANDERLIB" - fi - /bin/rm -f testp.cpp testp compile.err - else - # No check - CPPTRAJ_LIB=$CPPTRAJ_LIB" $SANDERLIB" - CXXFLAGS=$CXXFLAGS" $SANDERINC -DUSE_SANDERLIB" - fi - fi + if [ "${LIB_STAT[$LSANDER]}" = 'amberopt' ] ; then + TestProgram silent " Checking for sanderlib" "$CXX" "$CXXFLAGS ${LIB_INCL[$LSANDER]}" testp.cpp "${LIB_FLAG[$LSANDER]}" + if [ $? -eq 1 ] ; then + echo "Warning: SANDER test failed. CPPTRAJ will be built without the SANDER API." + LIB_STAT[$LSANDER]='off' fi + else + TestProgram " Checking sanderlib" "$CXX" "$CXXFLAGS ${LIB_INCL[$LSANDER]}" testp.cpp "${LIB_FLAG[$LSANDER]}" fi - if [[ $SL_ERR -ne 0 ]] ; then - if [ "$USE_SANDERLIB" -eq 2 ] ; then - echo "Error: Could not configure the SANDER API." - echo "" - exit 1 +} + +#------------------------------------------------------------------------------- +# Test external libraries +TestLibraries() { + if [ "${LIB_TEST[$LBZIP]}" = 'yes' ] ; then TestBzlib ; fi + if [ "${LIB_TEST[$LZIP]}" = 'yes' ] ; then TestZlib ; fi + if [ "${LIB_TEST[$LNETCDF]}" = 'yes' ] ; then TestNetcdf ; fi + if [ "${LIB_TEST[$LPARANC]}" = 'yes' ] ; then TestPnetcdf ; fi + if [ "${LIB_TEST[$LBLAS]}" = 'yes' ] ; then TestMathlib ; fi + if [ "${LIB_TEST[$LARPACK]}" = 'yes' ] ; then TestArpack ; fi + if [ "${LIB_TEST[$LFFTW3]}" = 'yes' ] ; then TestFFTW3 ; fi + if [ "${LIB_TEST[$LREADLINE]}" = 'yes' ] ; then TestReadline ; fi + if [ "${LIB_TEST[$LXDRFILE]}" = 'yes' ] ; then TestXdrfile ; fi + if [ "${LIB_TEST[$LSANDER]}" = 'yes' ] ; then TestSanderlib ; fi + # TODO test cuda? +} + +#------------------------------------------------------------------------------- +# Set final flags for compiling and linking. +SetupFinalFlags() { + # Basic directives + if [ $USE_MPI -ne 0 ] ; then DIRECTIVES="$DIRECTIVES -DMPI" ; fi + if [ $USE_CPPTRAJDEBUG -ne 0 ] ; then DIRECTIVES="$DIRECTIVES -DDEBUG" ; fi + if [ $USE_SINGLEENSEMBLE -ne 0 ] ; then DIRECTIVES="$DIRECTIVES -DENABLE_SINGLE_ENSEMBLE" ; fi + if [ ! -z "$LFS" ] ; then DIRECTIVES="$DIRECTIVES $LFS" ; fi + if [ "$C11_SUPPORT" = 'yes' ] ; then + if [ "${LIB_STAT[$LFFTW3]}" != 'off' ] ; then + DIRECTIVES="$DIRECTIVES -DLIBPME -DFC_SYMBOL=2" + fi + fi + # Set up include and linking flags + ldf='' + CPPTRAJ_LIB='' + INCLUDE='' + nincl=0 + for ((i=0; i < $NLIB; i++)) ; do + if [ "${LIB_STAT[$i]}" == 'off' ] ; then + if [ ! -z "${LIB_DOFF[$i]}" ] ; then + DIRECTIVES="$DIRECTIVES ${LIB_DOFF[$i]}" + fi else - echo "Warning: CPPTRAJ will be built without the SANDER API." + if [ ! -z "${LIB_D_ON[$i]}" ] ; then + DIRECTIVES="$DIRECTIVES ${LIB_D_ON[$i]}" + fi + # Include directories + if [ ! -z "${LIB_INCL[$i]}" ] ; then + # Search for previous include + idir=${LIB_INCL[$i]} + for ((j=0; j < $nincl; j++)) ; do + if [ "${include_array[$j]}" = "$idir" ] ; then + # Already included + #echo "DEBUG: $idir already included" + idir='' + break + fi + done + if [ ! -z "$idir" ] ; then + # Not yet included + #echo "DEBUG: $idir new inclusion" + include_array[$nincl]=$idir + ((nincl++)) + INCLUDE="$INCLUDE $idir" + fi + fi + # Link flags + if [ "${LIB_TYPE[$i]}" = 'ld' ] ; then + ldf="$ldf ${LIB_FLAG[$i]}" + elif [ "${LIB_TYPE[$i]}" = 'cpp' ] ; then + CPPTRAJ_LIB="$CPPTRAJ_LIB ${LIB_FLAG[$i]}" + fi fi + done + if [ $REQUIRES_FLINK -eq 1 ] ; then + CPPTRAJ_LIB="$CPPTRAJ_LIB $FLINK" fi + LDFLAGS="$ldf $LDFLAGS" } -# Test C/C++/Fortran compilers -TestCompile() { - # C - echo "Testing C compiler:" - cat > testp.c < -int main() { printf("Testing\n"); return 0; } -EOF - $CC $CFLAGS -o testp testp.c > /dev/null 2> compile.err - ./testp | grep "Testing" > /dev/null - status=$? - if [[ $status -gt 0 ]] ; then - CompileError "$CC $CFLAGS" - fi - /bin/rm -f testp.c testp compile.err - echo " OK" - # C++ - echo "Testing C++ compiler:" - cat > testp.cpp < -int main() { printf("Testing\n"); return 0; } -EOF - $CXX $CXXFLAGS -o testp testp.cpp > /dev/null 2> compile.err - ./testp | grep "Testing" > /dev/null - status=$? - if [[ $status -gt 0 ]] ; then - CompileError "$CXX $CXXFLAGS" +#------------------------------------------------------------------------------- +# Setup include and linker flags for external libraries +SetupLibraries() { + # Additional BLAS setup if necessary. Done here to override -amberlib. + if [ "$BLAS_TYPE" = 'none' ] ; then + LIB_STAT[$LBLAS]='off' + LIB_STAT[$LLAPACK]='off' + LIB_STAT[$LARPACK]='off' + elif [ "$BLAS_TYPE" = 'mkl' ] ; then + SetupMKL + elif [ "$BLAS_TYPE" = 'libsci' ] ; then + LIB_STAT[$LBLAS]='enabled' + LIB_HOME[$LBLAS]='' + LIB_LINK[$LBLAS]='dynamic' + LIB_FLAG[$LBLAS]='' + LIB_STAT[$LLAPACK]='off' + LIB_FLAG[$LLAPACK]='' + elif [ "$BLAS_TYPE" = 'openblas' ] ; then + LIB_FLAG[$LBLAS]='-lopenblas' + LIB_STAT[$LLAPACK]='off' + LIB_FLAG[$LLAPACK]='' + LIB_STAT[$LARPACK]='enabled' + LIB_HOME[$LARPACK]='' + elif [ "$BLAS_TYPE" = 'macAccelerate' ] ; then + LIB_FLAG[$LBLAS]='-framework Accelerate' + LIB_STAT[$LLAPACK]='off' + LIB_FLAG[$LLAPACK]='' + elif [ $USE_AMBERLIB -eq 1 ] ; then + if [ "${LIB_STAT[$LBLAS]}" == 'enabled' ] ; then + echo " Using blas from $AMBERHOME" + LIB_STAT[$LBLAS]='specified' + LIB_HOME[$LBLAS]=$AMBERHOME + LIB_LINK[$LBLAS]='static' + fi + if [ "${LIB_STAT[$LLAPACK]}" == 'enabled' ] ; then + echo " Using lapack from $AMBERHOME" + LIB_STAT[$LLAPACK]='specified' + LIB_HOME[$LLAPACK]=$AMBERHOME + LIB_LINK[$LLAPACK]='static' + fi fi - /bin/rm -f testp.cpp testp compile.err - echo " OK" - # Fortran - only needed if pub_fft.F90 needs to be compiled. - if [[ ! -z $FFT_DEPEND ]] ; then - echo "Testing Fortran compiler:" - cat > testp.f < /dev/null 2> compile.err - ./testp | grep "testing a Fortran program" > /dev/null - status=$? - if [[ $status -gt 0 ]] ; then - CompileError "$FC $FFLAGS" + # Use AMBERHOME to fill in libraries if needed + if [ $USE_AMBERLIB -eq 1 ] ; then + if [ "${LIB_STAT[$LNETCDF]}" == 'enabled' ] ; then + echo " Using netcdf from $AMBERHOME" + LIB_STAT[$LNETCDF]='specified' + LIB_HOME[$LNETCDF]=$AMBERHOME + LIB_LINK[$LNETCDF]='static' + fi + if [ "${LIB_STAT[$LARPACK]}" == 'enabled' -a "$BLAS_TYPE" != 'openblas' ] ; then + echo " Using arpack from $AMBERHOME" + LIB_STAT[$LARPACK]='specified' + LIB_HOME[$LARPACK]=$AMBERHOME + LIB_LINK[$LARPACK]='static' + fi + if [ "${LIB_STAT[$LFFTW3]}" = 'off' ] ; then + LIB_STAT[$LFFTW3]='amberopt' + LIB_LINK[$LFFTW3]='static' + elif [ "${LIB_STAT[$LFFTW3]}" == 'enabled' ] ; then + LIB_STAT[$LFFTW3]='specified' + LIB_HOME[$LFFTW3]=$AMBERHOME + LIB_LINK[$LFFTW3]='static' fi - /bin/rm -f testp.f testp compile.err - echo " OK" fi + # For any 'amberopt' check that AMBERHOME is available. + for ((i=0; i < $NLIB; i++)) ; do + if [ "${LIB_STAT[$i]}" = 'amberopt' ] ; then + if [ -z "$AMBERHOME" ] ; then + echo "Warning: Compilation of ${LIB_CKEY[$i]} requires AMBERHOME to be set" + echo " if --with-${LIB_CKEY[$i]} not specified." + LIB_STAT[$i]='off' + else + LIB_HOME[$i]=$AMBERHOME + fi + fi + done + # Set up library paths + for ((i=0; i < $NLIB; i++)) ; do + lhome='' + linc='' + lflag='' + if [ "${LIB_STAT[$i]}" = 'off' ] ; then + #echo "${LIB_CKEY[$i]} disabled." # DEBUG + LIB_TEST[$i]='no' + else + #echo "${LIB_CKEY[$i]} enabled." # DEBUG + # Static/dynamic linking + if [ "${LIB_STAT[$i]}" = 'specified' -a $USE_STATIC -eq 2 ] ; then + LIB_LINK[$i]='static' + fi + lhome=${LIB_HOME[$i]} + #echo DEBUG $lhome ${LIB_STAT[$i]} + if [ "${LIB_STAT[$i]}" = 'bundled' ] ; then + LIB_TEST[$i]='no' + linc="-I$lhome" + lflag="$lhome/${LIB_STTC[$i]}" + else + LIB_TEST[$i]=$PERFORM_CHECKS + if [ -z "$lhome" ] ; then + # Lib home not specified + if [ "${LIB_LINK[$i]}" = 'static' ] ; then + Err "'-libstatic' requires --with-${LIB_CKEY[$i]} specified." + fi + lflag=${LIB_FLAG[$i]} + else + # Lib home specified + linc="-I$lhome/include" + # Check if lib or lib64 exists. Prefer 'lib' for backwards compat. + lhdir="$lhome/lib" + if [ ! -d "$lhdir" ] ; then + lhdir="$lhome/lib64" + fi + if [ "${LIB_LINK[$i]}" = 'static' ] ; then + if [ -z "${LIB_STTC[$i]}" ] ; then + echo "Warning: Cannot link '${LIB_CKEY[$i]}' statically." + lflag="-L$lhdir ${LIB_FLAG[$i]}" + else + lflag="$lhdir/${LIB_STTC[$i]}" + fi + else + lflag="-L$lhdir ${LIB_FLAG[$i]}" + fi + # Library-specific INCLUDE fixes + if [ $i -eq $LREADLINE ] ; then + linc="$linc/readline" + fi + if [ $i -eq $LXDRFILE ] ; then + linc="$linc/xdrfile" + fi + fi + # Library-specific flag fixes + if [ $i -eq $LREADLINE ] ; then + # For external readline, we need to link libtermcap for windows + # and libncurses for Linux + #if [ $USE_WINDOWS -eq 1 ]; then + lflag="$lflag -ltermcap" + #else + # lflag="$lflag -lncurses" + #fi + elif [ $i -eq $LSANDER ] ; then + # Always specify libsander location to prevent pulling in + # other amber libraries. + lflag="${LIB_HOME[$LSANDER]}/lib/libsander$SHARED_SUFFIX" + fi + fi + #echo "${LIB_CKEY[$i]} ${LIB_STAT[$i]} linc $linc lflag $lflag" # DEBUG + LIB_FLAG[$i]="$lflag" + LIB_INCL[$i]="$linc" + fi + done } #------------------------------------------------------------------------------- -# Usage: SetCompilerOptions -SetCompilerOptions() { - case "$1" in - "gnu" ) - echo "Using GNU compilers" +# Set up compiler commands and compiler options +SetupCompilers() { + if [ ! -z "$CXX" ] ; then echo "C++ compiler (CXX) set to $CXX" ; fi + if [ ! -z "$CC" ] ; then echo "C compiler (CC) set to $CC" ; fi + if [ ! -z "$FC" ] ; then echo "Fortran compiler (FC) set to $FC" ; fi + # If no compiler type specified try to guess + if [ -z "$COMPILERS" ] ; then + if [ ! -z "$CXX" ] ; then + echo "Determining compilers from CXX ($CXX)" + case "$CXX" in + *g++* ) COMPILERS='gnu' ;; + *clang++* ) COMPILERS='clang' ;; + *icpc* ) COMPILERS='intel' ;; + *pgc++* ) COMPILERS='pgi' ;; + *CC* ) COMPILERS='cray' ;; + * ) echo "Warning: Could not detect compiler type ($CXX); assuming GNU" > /dev/stderr;; + esac + fi + fi + # If still no compiler default to gnu + if [ -z "$COMPILERS" ] ; then + # On OSX sometimes gnu means clang + if [ "$PLATFORM" = 'Darwin' -a ! -z "`g++ --version | grep LLVM`" ] ; then + echo "No compilers specified; defaulting to Apple clang (gnu)" + COMPILERS='clang' + else + echo "No compilers specified; defaulting to gnu" + COMPILERS='gnu' + fi + fi + # Set compiler options + optflags='' # C/C++ compiler optimization flags + foptflags='' # Fortran compiler optimization flags + ompflag='' # Compiler OpenMP flag + freefmtflag='' # Fortran free format flag + picflag='' # Compiler flag for position-independent code + warnflag='-Wall' + fwarnflag='' + DBFLAG='-g' + noinlineflag='-fno-inline' + commonflags='' + staticflag='-static' + staticlink='' + case "$COMPILERS" in + 'gnu' ) if [ -z "$CC" ]; then CC=gcc; fi if [ -z "$CXX" ]; then CXX=g++; fi if [ -z "$FC" ]; then FC=gfortran; fi - OPTFLAGS="-O3 -Wall" - OMPFLAGS="-fopenmp" - FFLAGS="-ffree-form" - FOPTFLAGS="-O3" - FLIBS="$FLIBS $lgfortran $quadmath -w" - PICFLAG="-fPIC" + optflags='-O3' + ompflag='-fopenmp' + freefmtflag='-ffree-form' + foptflags='-O3' + FLINK='-lgfortran' + picflag='-fPIC' + C11FLAG='-std=gnu++11' + staticlink='-lquadmath' ;; - "clang" ) - echo "Using clang/gfortran compilers" + 'clang' ) if [ -z "$CC" ]; then CC=clang; fi if [ -z "$CXX" ]; then CXX=clang++; fi if [ -z "$FC" ]; then FC=gfortran; fi - OPTFLAGS="-O3 -Wall" - OMPFLAGS="-fopenmp" - FFLAGS="-ffree-form" - FOPTFLAGS="-O3" - FLIBS="$FLIBS $lgfortran $quadmath -w" - PICFLAG="-fPIC" + optflags='-O3' + ompflag='-fopenmp' + freefmtflag='-ffree-form' + foptflags='-O3' + FLINK='-lgfortran' + picflag='-fPIC' + C11FLAG='-std=c++11' ;; - "intel" ) - echo "Using Intel compilers" + 'intel' ) if [ -z "$CC" ]; then CC=icc; fi if [ -z "$CXX" ]; then CXX=icpc; fi if [ -z "$FC" ]; then FC=ifort; fi - OPTFLAGS="-O3 -Wall -fp-model precise -fp-model source" - OMPFLAGS="-openmp" - FFLAGS="-FR" - FOPTFLAGS="-ip -O3" - FLIBS="$FLIBS -lifport -lifcore" - PICFLAG="-fpic" + CXXFLAGS="-fp-model precise -fp-model source $CXXFLAGS" + CFLAGS="-fp-model precise -fp-model source $CFLAGS" + optflags='-O3' + VERSION_LINE=`$CXX -v 2>&1` + if [ $? -ne 0 ] ; then + echo "$VERSION_LINE" + Err "Could not check Intel C++ compiler version." + fi + MAJOR_V=`echo "$VERSION_LINE" | awk '{print $3}' | cut -d'.' -f1` + if [ $MAJOR_V -ge 16 ] ; then + ompflag='-qopenmp' + else + ompflag='-openmp' + fi + freefmtflag='-FR' + foptflags='-ip -O3' + fwarnflag='-warn all' + FLINK='-lifport -lifcore' + picflag="-fpic" + C11FLAG='-std=c++11' ;; "pgi" ) - echo "Using PGI compilers" if [ -z "$CC" ]; then CC=pgcc; fi if [ -z "$CXX" ]; then CXX=pgc++; fi if [ -z "$FC" ]; then FC=pgf90; fi - OPTFLAGS="-O2" - OMPFLAGS="-mp" - FFLAGS="-Mfree" - FOPTFLAGS="-fast -O3" - FLIBS="-pgf90libs" - PICFLAG="-fpic" + optflags='-fast' + foptflags='-fast' + if [ "$PLATFORM" = 'cray' ] ; then + ompflag='-mp=nonuma' + else + ompflag='-mp' + fi + noinlineflag='-Mnoautoinline' + warnflag='-Minform=warn' + freefmtflag='-Mfree' + FLINK='-pgf90libs' + picflag='-fpic' + C11FLAG='-std=c++11' ;; "cray" ) - echo "Using Cray compilers" - USECRAY=1 if [ -z "$CC" ]; then CC=cc; fi if [ -z "$CXX" ]; then CXX=CC; fi if [ -z "$FC" ]; then FC=ftn; fi - OPTFLAGS="-h gnu" - OMPFLAGS="" - FFLAGS="-f free -emf" - FOPTFLAGS="" - FLIBS="" - PICFLAG="-fpic" + CXXFLAGS="-h gnu $CXXFLAGS" + CFLAGS="-h gnu $CFLAGS" + optflags='' + ompflag='' + warnflag='-h msglevel_2' # This will also print cautions + fwarnflag='-m 2' + freefmtflag='-f free -emf' + foptflags='' + FLINK='' + picflag='-fpic' + C11FLAG='-hstd=c++11' + if [ $USE_OPENMP -eq 0 ] ; then + commonflags='-h noomp' + fi ;; - * ) echo "Error: Unknown compilers: $1" > /dev/stderr ; exit 1 ;; + * ) Err "Unknown compilers: $1" ;; esac + # Unless specified fortran warnflag is same as C/C++ + if [ -z "$fwarnflag" ] ; then fwarnflag=$warnflag ; fi + # Change to MPI compiler wrappers if specified. Not needed for cray. + if [ $USE_MPI -ne 0 -a "$COMPILERS" != 'cray' ] ; then + if [ $USE_MPI -eq 1 ] ; then + mpi_cc='mpicc' + mpi_cxx='mpicxx' + mpi_f90='mpif90' + elif [ $USE_MPI -eq 2 ] ; then + mpi_cc='mpiicc' + mpi_cxx='mpiicpc' + mpi_f90='mpiifort' + fi + if [ -z "$MPICC" ] ; then + CC=$mpi_cc + else + echo "MPI C compiler (MPICC) set to $MPICC" + CC=$MPICC + fi + if [ -z "$MPICXX" ] ; then + CXX=$mpi_cxx + else + echo "MPI C++ compiler (MPICXX) set to $MPICXX" + CXX=$MPICXX + fi + if [ -z "$MPIF90" ] ; then + FC=$mpi_f90 + else + echo "MPI Fortran compiler (MPIF90) set to $MPIF90" + FC=$MPIF90 + fi + fi + # Use cray wrappers + if [ "$PLATFORM" = 'cray' ] ; then + CC=cc + CXX=CC + FC=ftn + fi + # Sanity check + if [ -z "$CC" -o -z "$CXX" -o -z "$FC" ] ; then + echo "Error: No compiler specified and CXX not set." > /dev/stderr + UsageSimple + exit 1 + fi + # Turn off optimizations if necessary + if [ $USE_OPT -eq 0 ] ; then + optflags='-O0' + foptflags='-O0' + fi + # Turn off PI code if necessary + if [ $USE_SHARED -eq 0 ] ; then + picflag='' + fi + # Turn off debug flags if necessary + if [ $USE_DEBUG -eq 0 ] ; then + DBFLAG='' + noinlineflag='' + fi + # Turn off static flag if necessary + if [ $USE_STATIC -ne 1 ] ; then + staticflag='' + staticlink='' + fi + # Turn off openmp flag if necessary + if [ $USE_OPENMP -eq 0 ] ; then + ompflag='' + fi + # Set compiler flags + CXXFLAGS="$DBFLAG $warnflag $ompflag $optflags $noinlineflag $picflag $commonflags $CXXFLAGS" + CFLAGS="$DBFLAG $warnflag $ompflag $optflags $picflag $commonflags $CFLAGS" + F77FLAGS="$DBFLAG $fwarnflag $ompflag $foptflags $picflag $commonflags $FFLAGS" + FFLAGS="$DBFLAG $fwarnflag $ompflag $foptflags $picflag $freefmtflag $commonflags $FFLAGS" + LDFLAGS="$LDFLAGS $ompflag $staticflag $staticlink" + # DEBUG + #echo $CXX $CXXFLAGS + #echo $CC $CFLAGS + #echo $FC $FFLAGS } #------------------------------------------------------------------------------- -# Check any compiler version-specific stuff -CheckCompilerVersion() { - case "$1" in - "intel" ) - MAJOR_V=`$CXX -v 2>&1 | awk '{print $3}' | cut -d'.' -f1` - if [ $MAJOR_V -ge 16 ] ; then - OMPFLAGS='-qopenmp' +# Set up profiling if specified +SetupProfiling() { + if [ $USE_PROFILE -ne 0 ] ; then + if [ $USE_PROFILE -eq 1 -o $USE_PROFILE -eq 2 ] ; then + if [ "$COMPILERS" != 'gnu' ] ; then + Err "This profile option only supported by GNU compilers." fi - ;; - esac + if [ $USE_PROFILE -eq 1 ] ; then + CXXFLAGS="-pg $CXXFLAGS" + CFLAGS="-pg $CXXFLAGS" + LDFLAGS="-pg $LDFLAGS" + else + CXXFLAGS="$CXXFLAGS -D_GLIBCXX_PROFILE" + fi + elif [ $USE_PROFILE -eq 3 ] ; then + vtuneflags='' + if [ "$COMPILERS" = 'intel' ] ; then + vtuneflags='-debug inline-debug-info' + CFLAGS="-g $vtuneflags $CFLAGS" + CXXFLAGS="-g $vtuneflags $CXXFLAGS" + fi + LDFLAGS="-shared-intel -shared-libgcc $LDFLAGS" + fi + fi } #------------------------------------------------------------------------------- -# Check if first arg is help arg -if [[ $1 = "--help" || $1 = "-h" ]] ; then - UsageSimple - exit 0 -elif [[ $1 = "--full-help" ]] ; then - UsageSimple - UsageFull - exit 0 -fi - -CONFIGURECMD="./configure $*" - -echo "" - -# Determine architecture -ARCHITECTURE=`uname -m` -if [[ "$ARCHITECTURE" = "x86_64" || "$ARCHITECTURE" = "em64t" ]] ; then - IS_64BIT=1 - echo "Assuming 64 bit architecture." -else - IS_64BIT=0 - echo "Assuming 32 bit architecture." -fi - -# System env variables. Do not clear these yet. -#CC="" #CXX="" #FC="" -#CFLAGS="" #CXXFLAGS="" #FFLAGS="" #LDFLAGS="" -#DBGFLAGS="" -# Configure Options -COMPILERS="" -OPT=1 -USEMPI=0 -USEOPENMP=0 -USEOPENBLAS=0 -USETIMER=0 -PROFILE=0 -USECRAY=0 -USELIBSCI=0 -USESHARED=0 -SFX="" -EXE="" -CPPTRAJHOME="" -CPPTRAJBIN="" -CPPTRAJLIB="" -DIRECTIVES="" -DEBUGFLAGS="" -OPTFLAGS="" -OMPFLAGS="" -FOPTFLAGS="" -PICFLAG="" -LFS="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64" -INCLUDE="" -# Library flags -SHARED_SUFFIX=".so" -STATIC=0 -STATICFLAG="-static" -NETCDF_HOME="" -PNETCDF_HOME="" -BZLIB_HOME="" -ZLIB_HOME="" -BLAS_HOME="" -LAPACK_HOME="" -ARPACK_HOME="" -READLINE_HOME='readline' -READLINE_TARGET="$READLINE_HOME/libreadline.a" -READLINE=$READLINE_TARGET -XDRFILE_HOME='xdrfile' -XDRFILE_TARGET="$XDRFILE_HOME/libxdrfile.a" -XDRFILE=$XDRFILE_TARGET -NETCDFLIB="-lnetcdf" -PNETCDFLIB="" -BZLIB="-lbz2" -ZLIB="-lz" -BLAS="-lblas" -LAPACK="-llapack" -ARPACK="-larpack" -FFT_LIB="pub_fft.o" -FFT_LIBDIR="" -FFT_DEPEND=$FFT_LIB -USE_LIBCPPTRAJ=0 # Set to 1 if libcpptraj will be built -USE_SANDERLIB=1 # 1=search for sanderlib, 2=specify location -SANDERLIB_HOME="" -USE_AMBER_LIB=0 -USEMKL=0 -FLIBS="" -HDF5LIB="" #"-lhdf5_hl -lhdf5" -WINDOWS="no" -CROSS_COMPILE="no" -USECUDA=0 -CUDA_TARGET="" -CLEAN='yes' # Clean source directory if configure is successful -SKIP_CHECKS='no' # If 'yes', skip all tests. - -# Private variables -quadmath="" -external_readline="no" -lgfortran="-lgfortran" - -# Parse command line options -KEY="" -VALUE="" -while [[ ! -z $1 ]] ; do - # If arg is Key=Value, separate into Key and Value - VALUE="" - POS=`echo $1 | awk 'match($0,"="){print RSTART}'` - if [[ $POS -eq 1 ]] ; then - echo "Error: '=' cannot be first character in an argument." > /dev/stderr ; exit 1 - elif [[ $POS -gt 1 ]] ; then - ((PM1 = $POS - 1)) - KEY=${1:0:$PM1} - VALUE=${1:$POS} - if [[ $VALUE = "" ]] ; then - echo "Error: '$1': Expected =, missing ." > /dev/stderr ; exit 1 - fi - eval VALUE=$VALUE 2> /dev/null +# Basic compiler tests +TestCompilers() { + # C++ OpenMP + if [ $USE_OPENMP -eq 1 ] ; then + cat > testp.cpp < +#include +int main() { + int nthreads; +# pragma omp parallel + { + if (omp_get_thread_num() == 0) + nthreads = omp_get_num_threads(); + } + printf("%i threads Testing\n", nthreads); + return 0; +} +#endif +EOF + TestProgram " Testing C++ compiler (OpenMP)" "$CXX" "$CXXFLAGS" testp.cpp else - KEY=$1 + # C++ + cat > testp.cpp < +int main() { printf("Testing\n"); return 0; } +EOF + TestProgram " Testing C++ compiler" "$CXX" "$CXXFLAGS" testp.cpp fi - #echo "KEY='$KEY', VALUE='$VALUE'" #DEBUG - # Process KEY - case "$KEY" in - "gnu" ) COMPILERS=$KEY ;; - "clang" ) COMPILERS=$KEY ;; - "intel" ) COMPILERS=$KEY ;; - "pgi" ) COMPILERS=$KEY ;; - "cray" ) COMPILERS=$KEY ;; - "CXX" ) CXX="$VALUE" ;; - "CC" ) CC="$VALUE" ;; - "FC" ) FC="$VALUE" ;; - "CXXFLAGS" ) CXXFLAGS="$VALUE" ;; - "CFLAGS" ) CFLAGS="$VALUE" ;; - "FFLAGS" ) FFLAGS="$VALUE" ;; - "LDFLAGS" ) LDFLAGS="$VALUE" ;; - "DBGFLAGS" ) DBGFLAGS="$VALUE" ;; - "-cray" ) - echo "Using Cray compiler wrappers (cc/CC/ftn)" - USECRAY=1 - ;; - "-libsci" ) # LibSci on cray needs no extra flags - echo "Using Cray LibSci for BLAS/LAPACK" - USELIBSCI=1 - BLAS="" - LAPACK="" - ;; - "-debug" ) - echo "Turning on compiler debug info" - DEBUGFLAGS="-g" - ;; - "-d" ) - echo "Turning on compiler debug info and disabling optimization" - DEBUGFLAGS="-g" - OPT=0 - ;; - "-debugon" ) - echo "Turning on cpptraj internal debug info" - DIRECTIVES="$DIRECTIVES -DDEBUG" - ;; - "-single-ensemble") - echo "Enabling support for single ensemble trajectories." - DIRECTIVES="$DIRECTIVES -DENABLE_SINGLE_ENSEMBLE" - ;; - "-noopt" ) - echo "Turning off optimization" - OPT=0 - ;; - "-mpi" ) USEMPI=1 ;; - "-intelmpi" ) USEMPI=2 ;; - "-openmp" ) USEOPENMP=1 ;; - "-cuda" ) USECUDA=1 ;; - "-profile" ) PROFILE=1 ;; - "-gprofile" ) PROFILE=2 ;; - "-vtune" ) PROFILE=3 ;; - "-timer" ) USETIMER=1 ;; - "-nolfs" ) - echo "Disabling large file support" - LFS="" - ;; - "-static" ) - echo "Using static linking." - STATIC=1 - ;; - "-libstatic" ) - echo "Using static linking for specified libraries." - STATIC=2 - ;; - "-shared" ) - echo "Enabling position-independent code for generating shared library." - USESHARED=1 - USE_LIBCPPTRAJ=1 - ;; - "-amberlib" ) - if [[ -z $AMBERHOME ]] ; then - echo "Error: '-amberlib' set but AMBERHOME is not defined." - echo " Set AMBERHOME and re-run configure." + # C + cat > testp.c < +int main() { printf("Testing\n"); return 0; } +EOF + TestProgram " Testing C compiler" "$CC" "$CFLAGS" testp.c + # Fortran - only needed if pub_fft.F90 needs to be compiled + if [ $REQUIRES_FLINK -eq 1 ] ; then + cat > testp.f < /dev/null 2>&1 - if [ $? -eq 0 ]; then - echo " Detected cross-compilation." - CROSS_COMPILE="yes" + mkldir=$MKL_HOME + else + mkldir=$MKLROOT + fi + echo "Using MKL for BLAS/LAPACK in $mkldir" + # Determine architecture + architecture=`uname -m` + if [ "$architecture" = 'x86_64' -o "$architecture" = 'em64t' ] ; then + echo " Assuming 64 bit architecture." + mkldir="$mkldir/lib/intel64" + mklinterface=libmkl_intel_lp64.a + mklblas="-lmkl_blas95_lp64" + mkllapack="-lmkl_lapack95_lp64" + else + echo " Assuming 32 bit architecture." + mkldir="$mkldir/lib/32" + mklinterface=libmkl_intel.a + mklblas="-lmkl_blas95" + mkllapack="-lmkl_lapack95" + fi + # Assume GNU linker. + if [ $USE_OPENMP -eq 1 ] ; then + if [ "$COMPILERS" = 'intel' ] ; then + mklthread='libmkl_intel_thread.a' + mklomp='-liomp5' + elif [ "$COMPILERS" = 'pgi' ] ; then + mklthread='libmkl_pgi_thread.a' + mklomp='-pgf90libs -mp' else - echo " Native windows build." - quadmath="-lquadmath" + mklthread='libmkl_gnu_thread.a' + mklomp='-lgomp' fi - EXE=".exe" - SHARED_SUFFIX='.dll.a' - ;; - "-openblas") - echo "Using OpenBLAS" - USEOPENBLAS=1 - ;; - "-noclean" ) - echo "Source directory will not be cleaned after 'configure'." - CLEAN='no' - ;; - "--skip-checks" ) SKIP_CHECKS='yes' ;; - "--with-bzlib" ) - INCLUDE="$INCLUDE -I$VALUE/include" - BZLIB_HOME="$VALUE" - echo "Using BZIP2 in $BZLIB_HOME" - ;; - "--with-zlib" ) - INCLUDE="$INCLUDE -I$VALUE/include" - ZLIB_HOME="$VALUE" - echo "Using ZLIB in $ZLIB_HOME" - ;; - "--with-netcdf" ) - INCLUDE="$INCLUDE -I$VALUE/include" - NETCDF_HOME="$VALUE" - echo "Using NetCDF in $NETCDF_HOME" - ;; - "--with-pnetcdf" ) - PNETCDF_HOME="$VALUE" - PNETCDFLIB="-lpnetcdf" - echo "Using parallel NetCDF in $PNETCDF_HOME" - ;; - "--with-blas" ) - INCLUDE="$INCLUDE -I$VALUE/include" - BLAS_HOME="$VALUE" - echo "Using BLAS in $BLAS_HOME" - ;; - "--with-lapack" ) - INCLUDE="$INCLUDE -I$VALUE/include" - LAPACK_HOME="$VALUE" - echo "Using LAPACK in $LAPACK_HOME" - ;; - "--with-arpack" ) - INCLUDE="$INCLUDE -I$VALUE/include" - ARPACK_HOME="$VALUE" - echo "Using ARPACK in $ARPACK_HOME" - ;; - "--with-fftw3" ) - INCLUDE="$INCLUDE -I$VALUE/include" - FFT_LIBDIR="-L$VALUE/lib" - echo "Using FFTW3 in $VALUE" - FFT_LIB="-lfftw3" - FFT_DEPEND="" - DIRECTIVES="$DIRECTIVES -DFFTW_FFT" - ;; - "--with-sanderlib" ) - SANDERLIB_HOME=$VALUE - USE_SANDERLIB=2 - ;; -# "--with-hdf5" ) -# INCLUDE="$INCLUDE -I$VALUE/include" -# HDF5LIB="-I$VALUE/include $VALUE/lib/libhdf5_hl.a $VALUE/lib/libhdf5.a -lm" -# echo "Using HDF5LIB: $HDF5LIB" -# ;; - "--with-readline") - echo "Using external readline" - READLINE_TARGET="noreadline" - READLINE="-L$VALUE/lib -lreadline" - external_readline="yes" - ;; - "--with-xdrfile") - echo "Using external xdrfile" - XDRFILE_HOME=$VALUE - XDRFILE_TARGET='noxdrfile' - XDRFILE="-L$VALUE/lib -lxdrfile" - ;; - "--prefix" ) - CPPTRAJHOME=$VALUE - CPPTRAJBIN=$VALUE/bin - CPPTRAJLIB=$VALUE/lib - ;; - * ) - echo "Unrecognized Option: $1" - echo "Use '-h' or '--help' for help." - exit 1 - ;; - esac - shift -done - -if [ "$USE_SANDERLIB" -eq 1 ] ; then - echo "SANDER API will be used if found in '$AMBERHOME'." -elif [ "$USE_SANDERLIB" -eq 2 ] ; then - echo "Using SANDER API in '$SANDERLIB_HOME'." -else - echo "CPPTRAJ will be compiled without the SANDER API." -fi - -# For external readline, we need to link libtermcap for windows and libncurses -# for Linux -if [ "$external_readline" = "yes" ]; then - if [ "$WINDOWS" = "yes" ]; then - READLINE="$READLINE -ltermcap" + mkllib="-L$mkldir $mkllapack $mklblas -Wl,--start-group $mkldir/$mklinterface $mkldir/$mklthread $mkldir/libmkl_core.a -Wl,--end-group $MKLOMP -lpthread -lm -ldl" else - READLINE="$READLINE -lncurses" + mkllib="-L$mkldir $mkllapack $mklblas -Wl,--start-group $mkldir/$mklinterface $mkldir/libmkl_sequential.a $mkldir/libmkl_core.a -Wl,--end-group -lpthread -lm -ldl" fi -fi - -if [ -z "$ARPACK" ] ; then - # If using -macAccelerate or -openblas witout ARPACK probably do not need -lgfortran - if [ "$BLAS" = '-framework Accelerate' -o "$USEOPENBLAS" -eq 1 ] ; then - lgfortran="" - fi -fi - -# If compiler has not yet been specified, determine from CXX, otherwise default -# to GNU -if [ ! -z "$CXX" ] ; then - echo "C++ compiler (CXX) set to $CXX" -fi -if [ ! -z "$CC" ] ; then - echo "C compiler (CC) set to $CC" -fi -if [ ! -z "$FC" ] ; then - echo "Fortran compiler (FC) set to $FC" -fi -if [[ -z $COMPILERS ]] ; then - if [[ ! -z $CXX ]] ; then - echo "Determining compilers from CXX ($CXX)" - COMPILERS='gnu' - case "$CXX" in - *g++* ) COMPILERS='gnu' ;; - *clang++* ) COMPILERS='clang' ;; - *icpc* ) COMPILERS='intel' ;; - *pgc++* ) COMPILERS='pgi' ;; - *CC* ) COMPILERS='cray' ;; - * ) echo "Warning: Could not detect compiler type ($CXX); assuming GNU" > /dev/stderr;; - esac - else - COMPILERS='gnu' - echo "No compilers specified; defaulting to GNU." - fi -fi -SetCompilerOptions $COMPILERS - -CheckCompilerVersion $COMPILERS - -# Check that OpenMP will work if it was specified -TestOpenMP - -# Check install directory -if [[ -z $CPPTRAJHOME ]] ; then - # Default is to use current directory. - CPPTRAJHOME=`pwd` - CPPTRAJBIN=$CPPTRAJHOME/bin - CPPTRAJLIB=$CPPTRAJHOME/lib -elif [[ ! -e $CPPTRAJHOME ]] ; then - echo "Error: Install directory '$CPPTRAJHOME' does not exist." - exit 1 -fi -echo "Installing cpptraj binary to $CPPTRAJBIN" - -# Check for compilers -if [[ -z $CC || -z $CXX || -z $FC ]] ; then - echo "No compiler specified and CXX not set." - UsageSimple - exit 1 -fi - -# Add HDF5 flags to NETCDF -#if [[ ! -z $NETCDFLIB ]] ; then -# NETCDFLIB="$NETCDFLIB $HDF5LIB" -#fi - -# OpenBLAS -if [ $USEOPENBLAS -eq 1 ] ; then - BLAS="-lopenblas" - LAPACK="" -fi - -# If parallel NetCDF specified, ensure MPI is active. -if [ ! -z "$PNETCDFLIB" ] ; then - if [ $USEMPI -eq 0 ] ; then - echo "" - echo "Warning: '-lpnetcdf' specified but MPI not specified. Assuming '-mpi'" - echo "" - USEMPI=1 fi - if [ ! -z "$PNETCDF_HOME" ] ; then - INCLUDE="$INCLUDE -I$PNETCDF_HOME/include" - fi -fi - -# Add directives -if [[ ! -z $BZLIB ]] ; then - DIRECTIVES="$DIRECTIVES -DHASBZ2" -fi -if [[ ! -z $ZLIB ]] ; then - DIRECTIVES="$DIRECTIVES -DHASGZ" -fi -if [[ ! -z $NETCDFLIB ]] ; then - DIRECTIVES="$DIRECTIVES -DBINTRAJ" -fi -if [[ ! -z $PNETCDFLIB ]] ; then - DIRECTIVES="$DIRECTIVES -DHAS_PNETCDF" -fi + LIB_STAT[$LBLAS]='enabled' + LIB_HOME[$LBLAS]='' + LIB_LINK[$LBLAS]='dynamic' + LIB_FLAG[$LBLAS]="$mkllib" + LIB_STAT[$LLAPACK]='off' + LIB_FLAG[$LLAPACK]='' +} -# Use libraries in AMBERHOME for stuff thats undefined -if [[ $USE_AMBER_LIB -eq 1 ]] ; then - INCLUDE="$INCLUDE -I$AMBERHOME/include" - if [[ -z $BLAS_HOME && ! -z $BLAS ]] ; then - BLAS_HOME=$AMBERHOME - fi - if [[ -z $ARPACK_HOME && ! -z $ARPACK ]] ; then - ARPACK_HOME=$AMBERHOME - fi - if [[ -z $LAPACK_HOME && ! -z $LAPACK ]] ; then - LAPACK_HOME=$AMBERHOME +# ------------------------------------------------------------------------------ +# Check that CUDA_HOME is defined and set up flags for nvcc +SetupCUDA() { + if [ -z "$CUDA_HOME" ] ; then + Err "CUDA_HOME not set. Set CUDA_HOME to point to your NVIDIA tools installation." fi - if [[ -z $NETCDF_HOME && ! -z $NETCDFLIB ]] ; then - NETCDF_HOME=$AMBERHOME + if [ ! -x "$CUDA_HOME/bin/nvcc" ]; then + Err "Error: nvcc cuda compiler not found in $CUDA_HOME/bin" fi -fi - -if [ ! -z "$XDRFILE" ] ; then - if [ "$XDRFILE_TARGET" = 'noxdrfile' ] ; then - INCLUDE="$INCLUDE -I$XDRFILE_HOME/include" - else - INCLUDE="$INCLUDE -I$XDRFILE_HOME" + if [ -z "$NVCC" ]; then NVCC="$CUDA_HOME/bin/nvcc"; fi + cuda_version=`$NVCC --version | grep 'release' | cut -d' ' -f5 | cut -d',' -f1` + echo " CUDA version $cuda_version detected." + SM_CONFIG="Configuring for $SHADER_MODEL" + if [ -z "$NVCCFLAGS" -a -z "$SHADER_MODEL" ] ; then + echo "Warning: SHADER_MODEL not set. Compiling for multiple architectures." + echo "Warning: To compile for a specific architecture set SHADER_MODEL" + echo "Warning: to 'sm_XX', where XX is the shader model version." + # NOTE: From AmberTools configure2 + #Note at present we do not include SM3.5 or SM3.7 since they sometimes show performance + #regressions over just using SM3.0. + sm62flags='-gencode arch=compute_62,code=sm_62' + sm61flags='-gencode arch=compute_61,code=sm_61' + sm60flags='-gencode arch=compute_60,code=sm_60' + sm53flags='-gencode arch=compute_53,code=sm_53' + sm52flags='-gencode arch=compute_52,code=sm_52' + sm50flags='-gencode arch=compute_50,code=sm_50' + sm37flags='-gencode arch=compute_37,code=sm_37' + sm35flags='-gencode arch=compute_35,code=sm_35' + sm30flags='-gencode arch=compute_30,code=sm_30' + sm20flags='-gencode arch=compute_20,code=sm_20' + if [ "$cuda_version" = '9.0' ] ; then + SM_CONFIG="Configuring for SM3.0, SM5.0, SM5.2, SM5.3, SM6.0 and SM6.1" + NVCCFLAGS="$sm30flags $sm50flags $sm52flags $sm53flags $sm60flags $sm61flags" + elif [ "$cuda_version" = '8.0' ] ; then + SM_CONFIG="Configuring for SM2.0, SM3.0, SM5.0, SM5.2, SM5.3, SM6.0 and SM6.1" + NVCCFLAGS="$sm20flags $sm30flags $sm50flags $sm52flags $sm53flags $sm60flags $sm61flags" + else + SM_CONFIG="Configuring for SM2.0, SM3.0, SM5.0, SM5.2 and SM5.3" + echo "BE AWARE: CUDA < 8.0 does not support GTX-1080, Titan-XP, DGX-1 or other Pascal based GPUs." + NVCCFLAGS="$sm20flags $sm30flags $sm50flags $sm52flags $sm53flags" + fi fi -fi + if [ -z "$NVCCFLAGS" ]; then NVCCFLAGS="$DBFLAG -arch=$SHADER_MODEL"; fi + LIB_STAT[$LCUDA]='specified' + LIB_HOME[$LCUDA]=$CUDA_HOME + USE_CUDA=1 +} -# Static/Dynamic linking options -if [[ $STATIC -eq 2 ]] ; then - # Static linking for specified libraries - if [[ ! -z $BLAS_HOME && ! -z $BLAS ]] ; then - BLAS="$BLAS_HOME/lib/libblas.a" - fi - if [[ ! -z $ARPACK_HOME && ! -z $ARPACK ]] ; then - ARPACK="$ARPACK_HOME/lib/libarpack.a" - fi - if [[ ! -z $LAPACK_HOME && ! -z $LAPACK ]] ; then - LAPACK="$LAPACK_HOME/lib/liblapack.a" - fi - if [[ ! -z $NETCDF_HOME && ! -z $NETCDFLIB ]] ; then - NETCDFLIB="$NETCDF_HOME/lib/libnetcdf.a" - fi - if [[ ! -z $BZLIB_HOME && ! -z $BZLIB ]] ; then - BZLIB="$BZLIB_HOME/lib/libbz2.a" - fi - if [[ ! -z $ZLIB_HOME && ! -z $ZLIB ]] ; then - ZLIB="$ZLIB_HOME/lib/libz.a" - fi - if [[ ! -z $PNETCDF_HOME && ! -z $PNETCDFLIB ]] ; then - PNETCDFLIB="$PNETCDF_HOME/lib/libpnetcdf.a" - fi -else - # Dynamic linking - if [[ ! -z $BLAS_HOME && ! -z $BLAS ]] ; then - BLAS="-L$BLAS_HOME/lib $BLAS" - fi - if [[ ! -z $ARPACK_HOME && ! -z $ARPACK ]] ; then - ARPACK="-L$ARPACK_HOME/lib $ARPACK" - fi - if [[ ! -z $LAPACK_HOME && ! -z $LAPACK ]] ; then - LAPACK="-L$LAPACK_HOME/lib $LAPACK" - fi - if [[ ! -z $NETCDF_HOME && ! -z $NETCDFLIB ]] ; then - NETCDFLIB="-L$NETCDF_HOME/lib $NETCDFLIB" +# ------------------------------------------------------------------------------ +# Basic checks, set up some directives +BasicChecks() { + # Check install directory + if [ -z "$CPPTRAJHOME" ] ; then + # Default is to use current directory. + CPPTRAJHOME=`pwd` + CPPTRAJBIN=$CPPTRAJHOME/bin + CPPTRAJLIB=$CPPTRAJHOME/lib + elif [ ! -d "$CPPTRAJHOME" ] ; then + echo "Error: Install directory '$CPPTRAJHOME' does not exist." + exit 1 fi - if [[ ! -z $BZLIB_HOME && ! -z $BZLIB ]] ; then - BZLIB="-L$BZLIB_HOME/lib $BZLIB" + # Test incompatible options + if [ "$PLATFORM" = 'windows' ] ; then + if [ $USE_MPI -ne 0 ] ; then + Err "MPI not currently supported on Windows." + fi + if [ $USE_OPENMP -ne 0 ] ; then + Err "OpenMP not currently supported on Windows." + fi + echo "WINDOWS support requested. Implies '-static'." + USE_STATIC=1 fi - if [[ ! -z $ZLIB_HOME && ! -z $ZLIB ]] ; then - ZLIB="-L$ZLIB_HOME/lib $ZLIB" + if [ "${LIB_STAT[$LPARANC]}" != 'off' -a $USE_MPI -eq 0 ] ; then + echo "Warning: Parallel NetCDF enabled but MPI not specified. Assuming '-mpi'." + USE_MPI=1 fi - if [[ ! -z $PNETCDF_HOME && ! -z $PNETCDFLIB ]] ; then - PNETCDFLIB="-L$PNETCDF_HOME/lib $PNETCDFLIB" + # If pub_FFT.F90 will be compiled or we are using the bundled ARPACK + # then we will need C++/Fortran linking. + if [ "${LIB_STAT[$LFFTW3]}" = 'off' -o "${LIB_STAT[$LARPACK]}" = 'bundled' ] ; then + REQUIRES_FLINK=1 fi -fi + # TODO if we skipped checks we may need the FLINK flag enabled + # Binary suffix + if [ $USE_MPI -ne 0 ] ; then SFX=$SFX".MPI" ; fi + if [ $USE_OPENMP -ne 0 ] ; then SFX=$SFX".OMP" ; fi + if [ $USE_CUDA -ne 0 ] ; then SFX=$SFX".cuda" ; fi +} -MKLLIB="" -if [[ $USEMKL -eq 1 ]] ; then - # Use MKL for LAPACK/BLAS - if [[ $IS_64BIT -eq 1 ]] ; then - MKLINTERFACE=libmkl_intel_lp64.a - MKLROOT="$MKLROOT/lib/intel64" - BLAS="-lmkl_blas95_lp64" - LAPACK="-lmkl_lapack95_lp64" - else # Assume 32 bit - MKLINTERFACE=libmkl_intel.a - MKLROOT="$MKLROOT/lib/32" - BLAS="-lmkl_blas95" - LAPACK="-lmkl_lapack95" - fi - # Assume GNU linker. - if [[ $USEOPENMP -eq 1 ]] ; then - if [ "$COMPILERS" = 'intel' ] ; then - MKLTHREAD='libmkl_intel_thread.a' - MKLOMP='-liomp5' - elif [ "$COMPILERS" = 'pgi' ] ; then - MKLTHREAD='libmkl_pgi_thread.a' - MKLOMP='-pgf90libs -mp' +#------------------------------------------------------------------------------- +# Platform-specific tests +PlatformTests() { + # C++11 support + if [ "$C11_SUPPORT" = 'yes' ] ; then + cat > testp.cpp < +int main() { constexpr int a = 5; auto b = a; for (auto i : {1, 2, 3}) { b += i; } return 0; } +EOF + TestProgram silent " Testing C++11 support" "$CXX" "$CXXFLAGS $C11FLAG" testp.cpp + if [ $? -eq 1 ] ; then + echo "Not present" + C11_SUPPORT='no' else - MKLTHREAD='libmkl_gnu_thread.a' - MKLOMP='-lgomp' + C11_SUPPORT='yes' + CXXFLAGS="$CXXFLAGS $C11FLAG" fi - MKLLIB="-L$MKLROOT $LAPACK $BLAS -Wl,--start-group $MKLROOT/$MKLINTERFACE $MKLROOT/$MKLTHREAD $MKLROOT/libmkl_core.a -Wl,--end-group $MKLOMP -lpthread -lm -ldl" - else - MKLLIB="-L$MKLROOT $LAPACK $BLAS -Wl,--start-group $MKLROOT/$MKLINTERFACE $MKLROOT/libmkl_sequential.a $MKLROOT/libmkl_core.a -Wl,--end-group -lpthread -lm -ldl" - fi - BLAS="" - LAPACK="" -fi - -# Determine platform type -PLATFORM=`uname -s | awk '{print $1}'` - -if [[ $PLATFORM = "Darwin" ]] ; then - echo "Detected OSX system." - # OSX-specific options - SHARED_SUFFIX=".dylib" - if [[ "$FFT_LIB" == "-lfftw3" && $USEOPENBLAS -eq 1 ]] ; then - # Linking against fortran libraries (e.g. -lgfortran) is not required on - # Mac OS X using FFTW3, since the the Mac Accelerate blas/lapack/arpack - # doesn't require any extra fortran libs, and fftw3 does not require - # fortran. - FLIBS="" fi - if [[ $COMPILERS = "clang" ]] ; then - # On OSX with clang, some libraries may be built with libstdc++ and will - # fail to link without this flag. + # Some compilers (like older Intel) have a problem with the order of + # stdio vs mpi + if [ $USE_MPI -ne 0 ] ; then cat > testp.cpp < +#include +int main() { printf("Testing a C++ MPI program.\n"); return 0; } +EOF + TestProgram quiet " Testing STDIO/MPI ordering" "$CXX" "$CXXFLAGS" testp.cpp + if [ $? -eq 1 ] ; then + # Try to fix it with -DMPICH_IGNORE_CXX_SEEK + TestProgram " Testing fix for STDIO/MPI ordering" "$CXX" "$CXXFLAGS -DMPICH_IGNORE_CXX_SEEK" testp.cpp + # That worked. Add to CXXFLAGS + CXXFLAGS="$CXXFLAGS -DMPICH_IGNORE_CXX_SEEK" + fi + fi + # ----- Mac OSX -------------------------------- + if [ "$PLATFORM" = 'Darwin' ] ; then + SHARED_SUFFIX='.dylib' + if [ "$COMPILERS" = 'clang' ] ; then + # On OSX with clang, some libraries may be built with libstdc++ and will + # fail to link without this flag. + cat > testp.cpp < #include int main() { std::string temp("Testing"); printf("%s\n", temp.c_str()); return 0; } EOF - # Test without stdlib flag - $CXX -o testp testp.cpp > /dev/null 2> /dev/null - ERR=$? - if [[ $ERR -ne 0 ]] ; then - # Test with stdlib flag - $CXX -o testp testp.cpp -stdlib=libstdc++ > /dev/null 2> /dev/null - ERR=$? - if [[ $ERR -eq 0 ]] ; then - LDFLAGS=$LDFLAGS" -stdlib=libstdc++" + TestProgram quiet "Without stdlib flag" "$CXX" "$CXXFLAGS" testp.cpp + if [ $? -eq 1 ] ; then + # Test with stdlib flag + TestProgram quiet "With stdlib flag" "$CXX" "$CXXFLAGS" testp.cpp "-stdlib=libstdc++" + if [ $? -eq 1 ] ; then + Err "Could not link properly with clang++ on OSX" + fi + LDFLAGS="$LDFLAGS -stdlib=libstdc++" fi - fi - # Check that program actually runs - if [[ $ERR -eq 0 ]] ; then - ./testp | grep "Testing" > /dev/null - ERR=$? - fi - if [[ $ERR -ne 0 ]] ; then - echo "Error: Could not link properly with clang++ on OSX." - exit 1 - fi - /bin/rm -f testp testp.cpp - # Test that we can link between C++ and Fortran - if [ ! -z "$lgfortran" ] ; then - printf "Testing clang++/gfortran linking...\n" - cat > testc.cpp < testc.cpp < extern "C" { void mytest_(int&); } int main() { int ival=14; printf("Testing"); mytest_(ival); } EOF - cat > testf.f < /dev/null 2> compile.err + if [ $? -ne 0 ] ; then + cat compile.err + exit 1 + fi + cat > testf.f < /dev/null - if [ "$?" -ne 0 ] ; then - echo " Initial link failed, attempting to find Fortran libraries..." - # Probably missing lgfortran. Search for it. - for FL_DIR in `$FC -print-search-dirs | grep "libraries:" | awk 'BEGIN{FS="[=:]";}{ - for (col=2; col <= NF; col++) - print $col; - }'` ; do - $CXX -o testp testc.o testf.o -L$FL_DIR $FLIBS $LDFLAGS 2> /dev/null - if [ "$?" -eq 0 ] ; then - FORTLIB_DIR="-L$FL_DIR" - break + $FC $FFLAGS -c -o testf.o testf.f > /dev/null 2> compile.err + if [ $? -ne 0 ] ; then + cat compile.err + exit 1 + fi + TestProgram quiet "clang++/gfortran link" "$CXX" " " "testc.o testf.o" "$FLINK" + if [ $? -ne 0 ] ; then + # Probably missing lgfortran Search for it + fortlib_dir='' + for fl_dir in `$FC -print-search-dirs | grep "libraries:" | awk 'BEGIN{FS="[=:]";}{ + for (col=2; col <= NF; col++) + print $col; + }'` ; do + TestProgram quiet "test" "$CXX" " " "testc.o testf.o" "-L$fl_dir $FLINK" + if [ $? -eq 0 ] ; then + fortlib_dir=$fl_dir + break + fi + done + if [ -z "$fortlib_dir" ] ; then + Err "Cannot link C++ and Fortran with clang." fi - done - if [ -z "$FORTLIB_DIR" ] ; then CompileError "$CXX $FLIBS $LDFLAGS" ; fi - echo " Fortran libraries found." + FLINK="-L$fortlib_dir $FLINK" + fi + echo "OK" fi - # At this point we should have a binary. Run it. - ./testp | grep Testing > /dev/null - if [ "$?" -ne 0 ] ; then CompileError "$CXX $FORTLIB_DIR $FLIBS $LDFLAGS" ; fi - /bin/rm -f testp test?.o testf.f testc.cpp - FLIBS="-L/usr/lib $FORTLIB_DIR $FLIBS" - fi # END clang++/gfortran link test - fi # END clang tests -elif [[ ! -z `echo $PLATFORM | grep -i cygwin` ]] ; then - echo "Detected Cygwin system." - PLATFORM="Cygwin" - SHARED_SUFFIX=".dll" -fi - -# Change to MPI compiler wrappers if specified -if [ $USEMPI -ne 0 ] ; then - if [ "$WINDOWS" = "yes" ] ; then - echo "MPI not currently supported on Windows" - exit 1 - fi - if [ -z "$PNETCDFLIB" ] ; then - echo "************************************************************************" - echo "* Warning: No parallel NetCDF library specified. *" - echo "* Warning: NetCDF parallel trajectory output requires parallel NetCDF. *" - echo "************************************************************************" - fi - DIRECTIVES="$DIRECTIVES -DMPI" - SFX=$SFX".MPI" - if [ "$USEMPI" -eq 1 ] ; then - echo "Using MPI" - mpi_cc='mpicc' - mpi_cxx='mpicxx' - mpi_f90='mpif90' - elif [ "$USEMPI" -eq 2 ] ; then - echo "Using Intel MPI" - mpi_cc='mpiicc' - mpi_cxx='mpiicpc' - mpi_f90='mpiifort' - fi - if [ -z "$MPICC" ] ; then - CC=$mpi_cc - else - echo "MPI C compiler (MPICC) set to $MPICC" - CC=$MPICC - fi - if [ -z "$MPICXX" ] ; then - CXX=$mpi_cxx - else - echo "MPI C++ compiler (MPICXX) set to $MPICXX" - CXX=$MPICXX - fi - if [ -z "$MPIF90" ] ; then - FC=$mpi_f90 + fi # End if clang + # ----- Windows/Cygwin ------------------------- + elif [ "$PLATFORM" = 'windows' ] ; then + SHARED_SUFFIX='.dll.a' + EXE='.exe' + # ----- Cygwin --------------------------------- + elif [ ! -z "`echo $PLATFORM | grep -i cygwin`" ] ; then + SHARED_SUFFIX='.dll' + # ----- Linux (default) ------------------------ else - echo "MPI Fortran compiler (MPIF90) set to $MPIF90" - FC=$MPIF90 + SHARED_SUFFIX='.so' fi - # Older Intel compilers have a problem with the order of stdio vs mpi - cat > testp.cpp < -#include -int main() { printf("Testing a C++ MPI program.\n"); return 0; } -EOF - $CXX -o testp testp.cpp > /dev/null 2> compile.err - if [ "$?" -ne 0 ] ; then - # Try to fix with -DMPICH_IGNORE_CXX_SEEK - $CXX -o testp -DMPICH_IGNORE_CXX_SEEK testp.cpp > /dev/null 2> compile.err - if [ "$?" -eq 0 ] ; then - # That worked. Add to CXXFLAGS - CXXFLAGS="$CXXFLAGS -DMPICH_IGNORE_CXX_SEEK" - else - echo "Error: Could not compile an MPI program with $CXX." > /dev/stderr - cat compile.err - exit 1 - fi - fi - rm -f testp.cpp testp compile.err -fi +} -# Set up linking flags if not already set. -# LDFLAGS contains flags common to cpptraj and ambpdb -LDFLAGS="$NETCDFLIB $PNETCDFLIB $BZLIB $ZLIB $XDRFILE $LDFLAGS" -# CPPTRAJ_LIB contains flags specific to cpptraj -CPPTRAJ_LIB="$ARPACK $LAPACK $BLAS $MKLLIB $FLIBS" -if [[ ! -z $FFT_LIBDIR ]] ; then - FFT_LIB="$FFT_LIBDIR $FFT_LIB" -fi +# ============================================================================== +# MAIN SCRIPT -# Add options for Timer -if [[ $USETIMER -eq 1 ]] ; then - DIRECTIVES="$DIRECTIVES -DTIMER" - LDFLAGS="$LDFLAGS -lrt" +# Check requirements +if [ -z "`which awk`" ] ; then + Err "CPPTRAJ configure requires 'awk'." fi - -# For pgi on cray modify some flags -if [[ $USECRAY -eq 1 && $COMPILERS = "pgi" ]] ; then - OPTFLAGS="-fast" - OMPFLAGS="-mp=nonuma" - FOPTFLAGS="-fast" +if [ -z "`which grep`" ] ; then + Err "CPPTRAJ configure requires 'grep'." fi -# Add flags for OPENMP if specified -if [[ $USEOPENMP -eq 1 ]] ; then - if [[ "$WINDOWS" = "yes" ]]; then - echo "OpenMP not currently supported on Windows" - exit 1 +CONFIGURECMD="./configure $*" + +# Process user options. +KEY='' +VALUE='' +while [ ! -z "$1" ] ; do + VALUE='' + # Check for '=' + #POS=`expr index "$1" =` # NOT PORTABLE + POS=`echo $1 | awk 'match($0,"="){print RSTART}'` + if [ -z "$POS" ] ; then POS=0 ; fi + if [ $POS -eq 1 ] ; then + Err "'=' cannot be the first character in an argument ($1)" + elif [ $POS -gt 1 ] ; then + # Separate into KEY and VALUE + ((PM1 = $POS - 1)) + KEY=${1:0:$PM1} + VALUE=${1:$POS} + if [ -z "$VALUE" ] ; then + Err "'$1': Expected =, missing ." + fi + eval VALUE=$VALUE 2> /dev/null + else + KEY=$1 fi - echo "Using OpenMP" - DIRECTIVES="$OMPFLAGS $DIRECTIVES" - LDFLAGS="$OMPFLAGS $LDFLAGS" - SFX=$SFX".OMP" -fi + #echo "KEY='$KEY' VALUE='$VALUE'" # DEBUG + # Process KEY + case "$KEY" in + '--help' | '-h' ) UsageSimple ; exit 0 ;; + '--full-help' ) UsageFull ; exit 0 ;; + # Compiler Options + 'gnu' ) COMPILERS=$KEY ;; + 'clang' ) COMPILERS=$KEY ;; + 'intel' ) COMPILERS=$KEY ;; + 'pgi' ) COMPILERS=$KEY ;; + 'cray' ) COMPILERS=$KEY ;; + 'CXX' ) CXX="$VALUE" ;; + 'CC' ) CC="$VALUE" ;; + 'FC' ) FC="$VALUE" ;; + 'CXXFLAGS' ) CXXFLAGS="$VALUE" ;; + 'CFLAGS' ) CFLAGS="$VALUE" ;; + 'FFLAGS' ) FFLAGS="$VALUE" ;; + 'F77FLAGS' ) F77FLAGS="$VALUE" ;; + 'LDFLAGS' ) LDFLAGS="$VALUE" ;; + 'DBGFLAGS' ) DBGFLAGS="$VALUE" ;; + # Build options + '-mpi' ) USE_MPI=1 ;; + '-intelmpi' ) USE_MPI=2 ;; + '-openmp' ) USE_OPENMP=1 ;; + '-cuda' ) SetupCUDA ;; + '-cray' ) PLATFORM='cray' ;; + '-mkl' ) BLAS_TYPE='mkl' ;; + '-libsci' ) BLAS_TYPE='libsci' ;; + '-openblas' ) BLAS_TYPE='openblas' ;; + '-macAccelerate' ) BLAS_TYPE='macAccelerate' ;; + '-debug' ) USE_DEBUG=1 ;; + '-d' ) USE_OPT=0 ; USE_DEBUG=1 ;; + '-noopt' ) USE_OPT=0 ;; + '-noc++11' ) C11_SUPPORT='no' ;; + '-windows' ) PLATFORM='windows' ;; + # Cpptraj options + '-nolfs' ) LFS='' ;; + '-single-ensemble' ) USE_SINGLEENSEMBLE=1 ;; + '-debugon' ) USE_CPPTRAJDEBUG=1 ;; + # Code profiling + '-profile' ) USE_PROFILE=1 ;; + '-gprofile' ) USE_PROFILE=2 ;; + '-vtune' ) USE_PROFILE=3 ;; + # Linking options + '-static' ) USE_STATIC=1 ;; + '-libstatic' ) USE_STATIC=2 ;; + '-shared' ) USE_SHARED=1 ;; + '-amberlib' ) + if [ -z "$AMBERHOME" ] ; then + Err "'-amberlib' requires that AMBERHOME be set." + fi + USE_AMBERLIB=1 + ;; + '-nomathlib' ) BLAS_TYPE='none' ;; + '--requires-flink' ) REQUIRES_FLINK=1 ;; + # Install options + '--compile-verbose' ) COMPILE_VERBOSE=1 ;; + '-noclean' ) CLEAN='no' ;; + '--skip-checks' ) PERFORM_CHECKS='no' ;; + '--prefix' ) + CPPTRAJHOME=$VALUE + CPPTRAJBIN=$VALUE/bin + CPPTRAJLIB=$VALUE/lib + ;; + * ) # Check for library keys + CheckLibraryKeys "$KEY" "$VALUE" + if [ $? -eq 1 ] ; then + Err "Unrecognized Option '$1'. Use '-h' or '--help' for help." + fi + ;; + esac + shift +done -# Remove opt flags if specified -if [[ $OPT -eq 0 ]] ; then - OPTFLAGS="" - FOPTFLAGS="" - DEBUGFLAGS="$DEBUGFLAGS -O0" +# Determine platform if not already specified +if [ -z "$PLATFORM" ] ; then + PLATFORM=`uname -s | awk '{print $1}'` fi -# Add flags specific to cray compilers -if [[ $COMPILERS = "cray" && $USEOPENMP -eq 0 ]] ; then - DIRECTIVES="-h noomp "$DIRECTIVES +# Basic checks and directives +BasicChecks + +# Set up compilers and compiler options +SetupCompilers + +# Set up profiling if specified +SetupProfiling + +# Basic Compiler tests +if [ "$PERFORM_CHECKS" = 'yes' ] ; then + TestCompilers fi -# Check that CUDA will work. -if [[ $USECUDA -eq 1 ]] ; then - echo "Using CUDA" - if [ -z "$CUDA_HOME" ] ; then - echo "Error: CUDA_HOME not set." > /dev/stderr - echo " Set CUDA_HOME to point to your NVIDIA tools installation." > /dev/stderr - exit 1 - fi - if [ ! -x "$CUDA_HOME/bin/nvcc" ]; then - echo "Error: nvcc cuda compiler not found in $CUDA_HOME/bin/" > /dev/stderr - exit 1 +# Platform-specific tests +PlatformTests + +# Set up external libraries +SetupLibraries + +# Test external libraries +TestLibraries + +# Set final compile flags +SetupFinalFlags + +# ----- Summary ---------------------------------- +echo "" +echo "Configuration summary:" +echo -n " Build type:" +if [ $USE_MPI -eq 0 -a $USE_OPENMP -eq 0 -a $USE_CUDA -eq 0 ] ; then + echo " Serial" +elif [ $USE_MPI -eq 0 -a $USE_OPENMP -eq 0 -a $USE_CUDA -ne 0 ] ; then + echo " CUDA" +else + if [ $USE_MPI -ne 0 -a $USE_OPENMP -ne 0 ] ; then + echo -n " Hybrid MPI/OpenMP" + elif [ $USE_MPI -ne 0 ] ; then + echo -n " MPI" + elif [ $USE_OPENMP -ne 0 ] ; then + echo -n " OpenMP" fi - if [ -z "$NVCC" ]; then NVCC="$CUDA_HOME/bin/nvcc"; fi - DIRECTIVES=$DIRECTIVES" -DCUDA" - CUDA_VERSION=`$NVCC --version | grep 'release' | cut -d' ' -f5 | cut -d',' -f1` - echo "CUDA version $CUDA_VERSION detected." - if [ -z "$NVCCFLAGS" -a -z "$SHADER_MODEL" ] ; then - echo "Warning: SHADER_MODEL not set. Compiling for multiple architectures." - echo "Warning: To compile for a specific architecture set SHADER_MODEL" - echo "Warning: to 'sm_XX', where XX is the shader model version." - # NOTE: From AmberTools configure2 - #Note at present we do not include SM3.5 or SM3.7 since they sometimes show performance - #regressions over just using SM3.0. - #SM6.2 = ??? - sm62flags='-gencode arch=compute_62,code=sm_62' - #SM6.1 = GP106 = GTX-1070, GP104 = GTX-1080, GP102 = Titan-X[P] - sm61flags='-gencode arch=compute_61,code=sm_61' - #SM6.0 = GP100 / P100 = DGX-1 - sm60flags='-gencode arch=compute_60,code=sm_60' - #SM5.3 = GM200 [Grid] = M60, M40? - sm53flags='-gencode arch=compute_53,code=sm_53' - #SM5.2 = GM200 = GTX-Titan-X, M6000 etc. - sm52flags='-gencode arch=compute_52,code=sm_52' - #SM5.0 = GM204 = GTX980, 970 etc - sm50flags='-gencode arch=compute_50,code=sm_50' - #SM3.7 = GK210 = K80 - sm37flags='-gencode arch=compute_37,code=sm_37' - #SM3.5 = GK110 + 110B = K20, K20X, K40, GTX780, GTX-Titan, GTX-Titan-Black, GTX-Titan-Z - sm35flags='-gencode arch=compute_35,code=sm_35' - #SM3.0 = GK104 = K10, GTX680, 690 etc. - sm30flags='-gencode arch=compute_30,code=sm_30' - #SM2.0 = All GF variants = C2050, 2075, M2090, GTX480, GTX580 etc. - sm20flags='-gencode arch=compute_20,code=sm_20' - if [ "$CUDA_VERSION" = '9.0' ] ; then - echo "Configuring for SM3.0, SM5.0, SM5.2, SM5.3, SM6.0 and SM6.1" - NVCCFLAGS="$sm30flags $sm50flags $sm52flags $sm53flags $sm60flags $sm61flags" - elif [ "$CUDA_VERSION" = '8.0' ] ; then - echo "Configuring for SM2.0, SM3.0, SM5.0, SM5.2, SM5.3, SM6.0 and SM6.1" - NVCCFLAGS="$sm20flags $sm30flags $sm50flags $sm52flags $sm53flags $sm60flags $sm61flags" - else - echo "Configuring for SM2.0, SM3.0, SM5.0, SM5.2 and SM5.3" - echo "BE AWARE: CUDA < 8.0 does not support GTX-1080, Titan-XP, DGX-1 or other Pascal based GPUs." - NVCCFLAGS="$sm20flags $sm30flags $sm50flags $sm52flags $sm53flags" - fi + if [ $USE_CUDA -ne 0 ] ; then + echo " + CUDA" + else + echo "" fi - if [ -z "$NVCCFLAGS" ]; then NVCCFLAGS="$DEBUGFLAGS -arch=$SHADER_MODEL"; fi - INCLUDE="$INCLUDE -I$CUDA_HOME/include" - LDFLAGS="$LDFLAGS -L$CUDA_HOME/lib64 -L$CUDA_HOME/lib -lcuda -lcudart" - CUDA_TARGET="cuda_kernels/libcpptraj_cuda.a" - SFX=$SFX".cuda" fi - -# Set up compiler flags if not already set -CFLAGS="$DEBUGFLAGS $OPTFLAGS $DIRECTIVES $LFS $INCLUDE $CFLAGS" -CXXFLAGS="$DEBUGFLAGS $OPTFLAGS $DIRECTIVES $LFS $INCLUDE $CXXFLAGS" -FFLAGS="$DEBUGFLAGS $FOPTFLAGS $DIRECTIVES $LFS $INCLUDE $FFLAGS" - -# Add position-independent code if necessary -if [[ $USESHARED -eq 1 ]] ; then - CFLAGS="$CFLAGS $PICFLAG" - CXXFLAGS="$CXXFLAGS $PICFLAG" - FFLAGS="$FFLAGS $PICFLAG" +if [ ! -z "$SM_CONFIG" ] ; then + echo " $SM_CONFIG" fi - -# Add debug flags for non-PGI compilers if debug info on -if [[ ! -z $DEBUGFLAGS && $COMPILERS != "pgi" ]] ; then - CFLAGS="-Wall $CFLAGS" - CXXFLAGS="-Wall -fno-inline $CXXFLAGS" - FFLAGS="-Wall $FFLAGS" +# DEBUG +#for ((i=0; i < $NLIB; i++)) ; do +# echo " Library: ${LIB_CKEY[$i]} (${LIB_STAT[$i]})" +#done +echo -n " Options:" +for ((i=0; i < $NLIB; i++)) ; do + if [ "${LIB_STAT[$i]}" != 'off' ] ; then + echo -n " ${LIB_CKEY[$i]}" + fi +done +echo "" +if [ $USE_SINGLEENSEMBLE -ne 0 ] ; then + echo " Support for single-ensemble trajectories enabled." fi - -# Turn on profiling for GNU if specified -if [[ $PROFILE -eq 1 && $COMPILERS = "gnu" ]] ; then - echo "Using $CXX profiling." - CFLAGS="-pg $CFLAGS" - CXXFLAGS="-pg $CXXFLAGS" - LDFLAGS="-pg $LDFLAGS" -elif [[ $PROFILE -eq 2 && $COMPILERS = "gnu" ]] ; then - echo "Turning on GLIBC profiling for $CXX." - CXXFLAGS="-D_GLIBCXX_PROFILE $CXXFLAGS" -elif [[ $PROFILE -eq 3 ]] ; then - echo "Turning on flags for Intel Vtune" - VTUNEFLAGS="" - if [[ $COMPILERS = "intel" ]] ; then - VTUNEFLAGS=$VTUNEFLAGS" -debug inline-debug-info" +echo " Target platform: $PLATFORM" +echo " $COMPILERS compilers in use." +if [ "$C11_SUPPORT" = 'yes' ] ; then + echo " C++11 support enabled." + if [ "${LIB_STAT[$LFFTW3]}" = 'off' ] ; then + echo " PME support disabled (requires FFTW3)." + else + echo " PME support enabled." fi - CFLAGS="-g $VTUNEFLAGS $CFLAGS" - CXXFLAGS="-g $VTUNEFLAGS $CXXFLAGS" - LDFLAGS="-shared-intel -shared-libgcc $LDFLAGS" +else + echo " C++11 support disabled." + echo " PME support disabled (requires C++11 and FFTW3)." fi - -# Use cray wrappers -if [ $USECRAY -eq 1 ] ; then - CC=cc - CXX=CC - FC=ftn +if [ $USE_OPT -eq 1 ] ; then + echo " Compiler optimizations are on." +else + echo " Compiler optimizations are off." fi - -# Set up static linking -if [[ $STATIC -eq 1 ]]; then - LDFLAGS="$LDFLAGS $STATICFLAG" +if [ $USE_DEBUG -ne 0 ] ; then + echo " Compiler debug symbols are on." +fi +if [ $USE_PROFILE -ne 0 ] ; then + echo " Code profiling is on." +fi +if [ "$BLAS_TYPE" != 'other' -a "$BLAS_TYPE" != 'none' ] ; then + echo " BLAS/LAPACK from: $BLAS_TYPE" fi +if [ -z "$LFS" ] ; then + echo " Large file support is off." +fi +if [ $USE_STATIC -eq 1 ] ; then + echo " Using static linking." +elif [ $USE_STATIC -eq 2 ] ; then + echo " Specified libraries will be linked statically if possible." +fi +#echo DIRECTIVES $DIRECTIVES +#echo CFLAGS $CFLAGS +#echo CXXFLAGS $CXXFLAGS +#echo FFLAGS $FFLAGS +#echo LDFLAGS $LDFLAGS +#echo CPPTRAJ_LIB $CPPTRAJ_LIB +#echo INCLUDE $INCLUDE +#echo REQUIRES_FLINK $REQUIRES_FLINK FLINK $FLINK +echo "" -# Test compilers (if we are not cross-compiling) -if [ "$CROSS_COMPILE" = "no" ] ; then - echo "" - if [ "$SKIP_CHECKS" = 'no' ] ; then - TestCompile - TestBzlib - TestZlib - TestNetcdf - TestPnetcdf - TestMathlib - TestArpack - TestFFTW3 - fi - TestSanderlib +if [ $USE_MPI -ne 0 -a "${LIB_STAT[$LPARANC]}" = 'off' ] ; then + echo "************************************************************************" + echo "* Warning: No parallel NetCDF library specified. *" + echo "* Warning: NetCDF parallel trajectory output requires parallel NetCDF. *" + echo "************************************************************************" fi -# Determine which targets to build +# ----- Determine which targets to build --------- CPPTRAJ_TARGET="" AMBPDB_TARGET="" LIBCPPTRAJ_TARGET="" @@ -1396,28 +1546,56 @@ INSTALL_TARGETS="" CPPTRAJ_TARGET=cpptraj$SFX$EXE INSTALL_TARGETS=$INSTALL_TARGETS" install_cpptraj" # Only build ambpdb in serial -if [ "$USEMPI" -eq 0 -a "$USEOPENMP" -eq 0 -a "$USECUDA" -eq 0 ] ; then +if [ $USE_MPI -eq 0 -a $USE_OPENMP -eq 0 -a $USE_CUDA -eq 0 ] ; then AMBPDB_TARGET=ambpdb INSTALL_TARGETS=$INSTALL_TARGETS" install_ambpdb" fi -# Can we build libcpptraj? -if [ "$USE_LIBCPPTRAJ" -eq 1 ] ; then +# Can we build libcpptraj? TODO serial/OpenMP only? +if [ $USE_SHARED -eq 1 ] ; then LIBCPPTRAJ_TARGET='$(CPPTRAJLIB)/libcpptraj$(SHARED_SUFFIX)' else LIBCPPTRAJ_TARGET='nolibcpptraj' fi # Only build nproc for MPI -if [ "$USEMPI" -ne 0 ] ; then +if [ $USE_MPI -ne 0 ] ; then NPROC_TARGET=nproc INSTALL_TARGETS=$INSTALL_TARGETS" $NPROC_TARGET" fi +# CUDA +if [ $USE_CUDA -eq 1 ] ; then + CUDA_TARGET='cuda_kernels/libcpptraj_cuda.a' +fi +# Readline +if [ "${LIB_STAT[$LREADLINE]}" = 'bundled' ] ; then + READLINE_TARGET=${LIB_FLAG[$LREADLINE]} +else + READLINE_TARGET='noreadline' +fi +# Xdrfile +if [ "${LIB_STAT[$LXDRFILE]}" = 'bundled' ] ; then + XDRFILE_TARGET=${LIB_FLAG[$LXDRFILE]} +else + XDRFILE_TARGET='noxdrfile' +fi +# Arpack +if [ "${LIB_STAT[$LARPACK]}" = 'bundled' ] ; then + ARPACK_TARGET=${LIB_FLAG[$LARPACK]} +else + ARPACK_TARGET='noarpack' +fi +# FFT +if [ "${LIB_STAT[$LFFTW3]}" = 'off' ] ; then + FFT_TARGET='pub_fft.o' +else + FFT_TARGET='' +fi -# Write config.h +# ----- Write config.h --------------------------- cat > config.h <> config.h fi cat >> config.h <> config.h fi cat >> config.h <> config.h <> config.h < /dev/null 2> /dev/null diff --git a/src/Action_Box.cpp b/src/Action_Box.cpp index a1b6837056..559c500cc9 100644 --- a/src/Action_Box.cpp +++ b/src/Action_Box.cpp @@ -58,23 +58,12 @@ Action::RetType Action_Box::Setup(ActionSetup& setup) { } Action::RetType Action_Box::DoAction(int frameNum, ActionFrame& frm) { - double* frame_box = frm.ModifyFrm().bAddress(); if (nobox_) { - frame_box[0] = 0.0; - frame_box[1] = 0.0; - frame_box[2] = 0.0; - frame_box[3] = 0.0; - frame_box[4] = 0.0; - frame_box[5] = 0.0; + frm.ModifyFrm().SetBox( Box() ); } else { Box fbox( box_ ); - fbox.SetMissingInfo( Box( frame_box ) ); - frame_box[0] = fbox.BoxX(); - frame_box[1] = fbox.BoxY(); - frame_box[2] = fbox.BoxZ(); - frame_box[3] = fbox.Alpha(); - frame_box[4] = fbox.Beta(); - frame_box[5] = fbox.Gamma(); + fbox.SetMissingInfo( frm.Frm().BoxCrd() ); + frm.ModifyFrm().SetBox( fbox ); } return Action::MODIFY_COORDS; } diff --git a/src/Action_Energy.cpp b/src/Action_Energy.cpp index 713cfd563a..c7d44cb530 100644 --- a/src/Action_Energy.cpp +++ b/src/Action_Energy.cpp @@ -1,36 +1,52 @@ #include "Action_Energy.h" #include "CpptrajStdio.h" +#include "Ewald_Regular.h" +#include "Ewald_ParticleMesh.h" -// CONSTRUCTOR -Action_Energy::Action_Energy() : currentParm_(0), debug_(0) +/// CONSTRUCTOR +Action_Energy::Action_Energy() : currentParm_(0), debug_(0), EW_(0) { std::fill(mlimits_, mlimits_+3, 0); } +/// DESTRUCTOR +Action_Energy::~Action_Energy() { + if (EW_ != 0) delete EW_; +} void Action_Energy::Help() const { mprintf("\t[] [] [out ]\n" - "\t[bond] [angle] [dihedral] [nb14] {[nonbond] | [elec] [vdw]}\n" - "\t[ etype {simple | directsum [npoints ] |\n" - "\t ewald [cut ] [dsumtol ] [rsumtol ]\n" - "\t [ewcoeff ] [maxexp ] [skinnb ]\n" - "\t [mlimits ,,]} ]\n" + "\t[bond] [angle] [dihedral] {[nb14] | [e14] | [v14]}\n" + "\t{[nonbond] | [elec] [vdw]} [kinetic [ketype {vel|vv}] [dt
]]\n" + "\t[ etype { simple |\n" + "\t directsum [npoints ] |\n" + "\t ewald [cut ] [dsumtol ] [rsumtol ]\n" + "\t [ewcoeff ] [maxexp ] [skinnb ]\n" + "\t [mlimits ,,] [erfcdx ]\n" + "\t pme [cut ] [dsumtol ] [order ]\n" + "\t [ewcoeff ] [skinnb ]\n" + "\t [nfft ,,] [erfcdx ]\n" + "\t } ]\n" " Calculate energy for atoms in mask.\n"); } -/// DataSet aspects -static const char* Estring[] = {"bond", "angle", "dih", "vdw14", "elec14", "vdw", "elec", "total"}; +/// Corresponds to Etype +static const char* AspectStr[] = {"bond", "angle", "dih", "vdw14", "elec14", + "vdw", "elec", "kinetic", "total"}; + +/// Corresponds to Etype +static const char* EtypeStr[] = {"Bonds", "Angles", "Dihedrals", "1-4 VDW", "1-4 Elec.", + "VDW", "Elec.", "Kinetic", "Total"}; -/// Calculation types -static const char* Cstring[] = {"Bond", "Angle", "Torsion", "1-4 Nonbond", "Nonbond", - "Electrostatics", "van der Waals", "Electrostatics (Direct Sum)", - "Electrostatics (Ewald)" }; +/// Corresponds to ElecType +static const char* ElecStr[] = { "None", "Simple", "Direct Sum", "Regular Ewald", + "Particle Mesh Ewald" }; // Action_Energy::AddSet() int Action_Energy::AddSet(Etype typeIn, DataSetList& DslIn, DataFile* outfile, - std::string const& setname) + std::string const& setnameIn) { - Energy_[typeIn] = DslIn.AddSet(DataSet::DOUBLE, MetaData(setname, Estring[typeIn])); + Energy_[typeIn] = DslIn.AddSet(DataSet::DOUBLE, MetaData(setnameIn, AspectStr[typeIn])); if (Energy_[typeIn] == 0) return 1; if (outfile != 0) outfile->AddDataSet( Energy_[typeIn] ); return 0; @@ -41,42 +57,69 @@ Action::RetType Action_Energy::Init(ArgList& actionArgs, ActionInit& init, int d { debug_ = debugIn; ENE_.SetDebug( debug_ ); - // Get keywords DataFile* outfile = init.DFL().AddDataFile( actionArgs.GetStringKey("out"), actionArgs ); - - // Which terms will be calculated? - bool calc_vdw = actionArgs.hasKey("vdw" ); - bool calc_elec = actionArgs.hasKey("elec"); - bool calc_nb = actionArgs.hasKey("nonbond"); - if (calc_vdw && calc_elec) - calc_nb = true; - if (calc_nb) { - calc_vdw = false; - calc_elec = false; + // Determine which energy terms are active + std::vector termEnabled((int)TOTAL+1, false); + termEnabled[BOND] = actionArgs.hasKey("bond"); + termEnabled[ANGLE] = actionArgs.hasKey("angle"); + termEnabled[DIHEDRAL] = actionArgs.hasKey("dihedral"); + termEnabled[V14] = actionArgs.hasKey("v14"); + termEnabled[Q14] = actionArgs.hasKey("e14"); + termEnabled[VDW] = actionArgs.hasKey("vdw"); + termEnabled[ELEC] = actionArgs.hasKey("elec"); + if (actionArgs.hasKey("nb14")) { + termEnabled[V14] = true; + termEnabled[Q14] = true; + } + if (actionArgs.hasKey("nonbond")) { + termEnabled[VDW] = true; + termEnabled[ELEC] = true; + } + termEnabled[KE] = actionArgs.hasKey("kinetic"); + int nactive = 0; + for (std::vector::const_iterator it = termEnabled.begin(); it != termEnabled.end(); ++it) + if (*it) ++nactive; + // If no terms specified, enabled everything. TODO disable KE? + if (nactive == 0) termEnabled.assign((int)TOTAL+1, true); + // If more than one term enabled ensure total will be calculated. + if (nactive > 1) termEnabled[TOTAL] = true; + // If KE enabled get type, time step, etc + KEtype_ = KE_NONE; + if (termEnabled[KE]) { + std::string ketype = actionArgs.GetStringKey("ketype"); + if (ketype.empty()) + KEtype_ = KE_AUTO; + else if (ketype == "vel") + KEtype_ = KE_VEL; + else if (ketype == "vv") + KEtype_ = KE_VV; + else { + mprinterr("Error: Unrecognized 'ketype': %s\n", ketype.c_str()); + return Action::ERR; + } + if (KEtype_ != KE_VEL) + dt_ = actionArgs.getKeyDouble("dt", 0.001); } - // Electrostatics type. If specified always split the Elec/VDW calc. - etype_ = SIMPLE; + // Electrostatics type. std::string etypearg = actionArgs.GetStringKey("etype"); + elecType_ = NO_ELE; + EW_ = 0; if (!etypearg.empty()) { - if (calc_nb) { - calc_nb = false; - calc_vdw = true; - } + termEnabled[ELEC] = true; if (etypearg == "directsum") { // Direct sum method - etype_ = DIRECTSUM; - calc_elec = true; + elecType_ = DIRECTSUM; npoints_ = actionArgs.getKeyInt("npoints", 0); } else if (etypearg == "ewald") { // Ewald method - etype_ = EW; - calc_elec = true; + elecType_ = EWALD; cutoff_ = actionArgs.getKeyDouble("cut", 8.0); dsumtol_ = actionArgs.getKeyDouble("dsumtol", 1E-5); rsumtol_ = actionArgs.getKeyDouble("rsumtol", 5E-5); ewcoeff_ = actionArgs.getKeyDouble("ewcoeff", 0.0); maxexp_ = actionArgs.getKeyDouble("maxexp", 0.0); skinnb_ = actionArgs.getKeyDouble("skinnb", 2.0); + erfcDx_ = actionArgs.getKeyDouble("erfcdx", 0.0); std::string marg = actionArgs.GetStringKey("mlimits"); if (!marg.empty()) { ArgList mlim(marg, ","); @@ -89,87 +132,127 @@ Action::RetType Action_Energy::Init(ArgList& actionArgs, ActionInit& init, int d mlimits_[2] = mlim.getNextInteger(0); } else std::fill(mlimits_, mlimits_+3, 0); + EW_ = (Ewald*)new Ewald_Regular(); + } else if (etypearg == "pme") { + // particle mesh Ewald method +# ifdef LIBPME + elecType_ = PME; + cutoff_ = actionArgs.getKeyDouble("cut", 8.0); + dsumtol_ = actionArgs.getKeyDouble("dsumtol", 1E-5); + ewcoeff_ = actionArgs.getKeyDouble("ewcoeff", 0.0); + skinnb_ = actionArgs.getKeyDouble("skinnb", 2.0); + erfcDx_ = actionArgs.getKeyDouble("erfcdx", 0.0); + npoints_ = actionArgs.getKeyInt("order", 6); + std::string marg = actionArgs.GetStringKey("nfft"); + if (!marg.empty()) { + ArgList mlim(marg, ","); + if (mlim.Nargs() != 3) { + mprinterr("Error: Need 3 integers in comma-separated list for 'nfft'\n"); + return Action::ERR; + } + mlimits_[0] = mlim.getNextInteger(0); + mlimits_[1] = mlim.getNextInteger(0); + mlimits_[2] = mlim.getNextInteger(0); + } else + std::fill(mlimits_, mlimits_+3, -1); + EW_ = (Ewald*)new Ewald_ParticleMesh(); +# else + mprinterr("Error: 'pme' requires compiling with FFTW3 and C++11 support.\n"); + return Action::ERR; +# endif } else if (etypearg == "simple") { // Simple method - etype_ = SIMPLE; - if (!calc_nb && !calc_elec) calc_elec = true; + elecType_ = SIMPLE; } else { mprinterr("Error: Unrecognized option for 'etype': %s\n", etypearg.c_str()); return Action::ERR; } } + // If electrostatics enabled but type not specified, default to SIMPLE + if (termEnabled[ELEC] && elecType_ == NO_ELE) elecType_ = SIMPLE; // Set up calculations Ecalcs_.clear(); - if (actionArgs.hasKey("bond")) Ecalcs_.push_back(BND); - if (actionArgs.hasKey("angle")) Ecalcs_.push_back(ANG); - if (actionArgs.hasKey("dihedral")) Ecalcs_.push_back(DIH); - if (actionArgs.hasKey("nb14")) Ecalcs_.push_back(N14); - if (calc_nb) Ecalcs_.push_back(NBD); - if (calc_vdw) Ecalcs_.push_back(LJ); - if (calc_elec) { - switch (etype_) { - case SIMPLE: Ecalcs_.push_back(COULOMB); break; - case DIRECTSUM: Ecalcs_.push_back(DIRECT); break; - case EW: Ecalcs_.push_back(EWALD); break; - } + if (termEnabled[BOND]) + Ecalcs_.push_back(C_BND); + if (termEnabled[ANGLE]) + Ecalcs_.push_back(C_ANG); + if (termEnabled[DIHEDRAL]) + Ecalcs_.push_back(C_DIH); + if (termEnabled[KE]) { + if (KEtype_ == KE_AUTO) + Ecalcs_.push_back(C_KEAUTO); + else if (KEtype_ == KE_VEL) + Ecalcs_.push_back(C_KEVEL); + else if (KEtype_ == KE_VV) + Ecalcs_.push_back(C_KEVV); } - // If nothing is selected, select all. - if (Ecalcs_.empty()) { - for (int c = 0; c <= (int)NBD; c++) - Ecalcs_.push_back( (CalcType)c ); + if (termEnabled[V14] || termEnabled[Q14]) + Ecalcs_.push_back(C_N14); + // Determine which nonbonded calc to use if any. + bool lj_longrange_correction = false; + need_lj_params_ = false; + if (termEnabled[ELEC] || termEnabled[VDW]) { + // NOTE: if elecType_ is not NO_ELE then ELEC term is enabled by default + if (elecType_ == SIMPLE) { + if (termEnabled[ELEC] && termEnabled[VDW]) { + Ecalcs_.push_back(C_NBD); + need_lj_params_ = true; + } else if (termEnabled[ELEC] && !termEnabled[VDW]) { + Ecalcs_.push_back(C_COULOMB); + } + } else if (elecType_ == DIRECTSUM) { + if (termEnabled[ELEC] && termEnabled[VDW]) { + Ecalcs_.push_back(C_LJ); + Ecalcs_.push_back(C_DIRECT); + need_lj_params_ = true; + } else if (termEnabled[ELEC] && !termEnabled[VDW]) { + Ecalcs_.push_back(C_DIRECT); + } + } else if (elecType_ == EWALD) { + Ecalcs_.push_back(C_EWALD); + lj_longrange_correction = true; + need_lj_params_ = true; + } else if (elecType_ == PME) { + Ecalcs_.push_back(C_PME); + lj_longrange_correction = true; + need_lj_params_ = true; + } else if (elecType_ == NO_ELE) { + Ecalcs_.push_back(C_LJ); + need_lj_params_ = true; + } } // Get Masks Mask1_.SetMaskString( actionArgs.GetMaskNext() ); // DataSet - std::string setname = actionArgs.GetStringNext(); - if (setname.empty()) - setname = init.DSL().GenerateDefaultName("ENE"); + setname_ = actionArgs.GetStringNext(); + if (setname_.empty()) + setname_ = init.DSL().GenerateDefaultName("ENE"); Energy_.clear(); Energy_.resize( (int)TOTAL + 1, 0 ); - for (calc_it calc = Ecalcs_.begin(); calc != Ecalcs_.end(); ++calc) + for (int i = 0; i != (int)TOTAL+1; i++) { - switch (*calc) { - case BND: if (AddSet(BOND, init.DSL(), outfile, setname)) return Action::ERR; break; - case ANG: if (AddSet(ANGLE, init.DSL(), outfile, setname)) return Action::ERR; break; - case DIH: if (AddSet(DIHEDRAL, init.DSL(), outfile, setname)) return Action::ERR; break; - case N14: - if (AddSet(V14, init.DSL(), outfile, setname)) return Action::ERR; - if (AddSet(Q14, init.DSL(), outfile, setname)) return Action::ERR; - break; - case NBD: - if (AddSet(VDW, init.DSL(), outfile, setname)) return Action::ERR; - if (AddSet(ELEC, init.DSL(), outfile, setname)) return Action::ERR; - break; - case LJ: - if (AddSet(VDW, init.DSL(), outfile, setname)) return Action::ERR; break; - case COULOMB: - case DIRECT: - case EWALD: - if (AddSet(ELEC, init.DSL(), outfile, setname)) return Action::ERR; break; + if (termEnabled[i]) { + if (AddSet((Etype)i, init.DSL(), outfile, setname_)) return Action::ERR; } } -// if (Ecalcs_.size() > 1) { - if (AddSet(TOTAL, init.DSL(), outfile, setname)) return Action::ERR; -// } mprintf(" ENERGY: Calculating energy for atoms in mask '%s'\n", Mask1_.MaskString()); mprintf("\tCalculating terms:"); - for (calc_it calc = Ecalcs_.begin(); calc != Ecalcs_.end(); ++calc) { - if (calc != Ecalcs_.begin()) mprintf(","); - mprintf(" %s", Cstring[*calc]); - } + for (int i = 0; i != (int)TOTAL+1; i++) + if (termEnabled[i]) mprintf(" '%s'", EtypeStr[i]); mprintf("\n"); - if (etype_ == DIRECTSUM) { + if (elecType_ != NO_ELE) + mprintf("\tElectrostatics method: %s\n", ElecStr[elecType_]); + if (elecType_ == DIRECTSUM) { if (npoints_ < 0) mprintf("\tDirect sum energy for up to %i unit cells in each direction will be calculated.\n", -npoints_); else mprintf("\tDirect sum energy for %i unit cells in each direction will be calculated.\n", npoints_); - } else if (etype_ == EW) { - mprintf("\tCalculating electrostatics with Ewald method.\n"); + } else if (elecType_ == EWALD) { mprintf("\tDirect space cutoff= %.4f\n", cutoff_); if (dsumtol_ != 0.0) mprintf("\tDirect sum tolerance= %g\n", dsumtol_); @@ -188,6 +271,38 @@ Action::RetType Action_Energy::Init(ArgList& actionArgs, ActionInit& init, int d else mprintf("\tNumber of reciprocal vectors in each direction= {%i,%i,%i}\n", mlimits_[0], mlimits_[1], mlimits_[2]); + if (erfcDx_ > 0.0) + mprintf("\tERFC table dx= %g\n", erfcDx_); + } else if (elecType_ == PME) { + mprintf("\tDirect space cutoff= %.4f\n", cutoff_); + if (dsumtol_ != 0.0) + mprintf("\tDirect sum tolerance= %g\n", dsumtol_); + mprintf("\tSpline order= %i\n", npoints_); + if (ewcoeff_ == 0.0) + mprintf("\tWill determine Ewald coefficient from cutoff and direct sum tolerance.\n"); + else + mprintf("\tEwald coefficient= %.4f\n", ewcoeff_); + if (mlimits_[0] < 1 && mlimits_[1] < 1 && mlimits_[2] < 1) + mprintf("\tWill determine number of FFT grid points from box size.\n"); + else + mprintf("\tNumber of FFT grid points in each direction= {%i,%i,%i}\n", + mlimits_[0], mlimits_[1], mlimits_[2]); + if (erfcDx_ > 0.0) + mprintf("\tERFC table dx= %g\n", erfcDx_); + } + if (termEnabled[VDW] && lj_longrange_correction) + mprintf("\tUsing long range correction for nonbond VDW calc.\n"); + if (KEtype_ != KE_NONE) { + if (KEtype_ == KE_AUTO) + mprintf("\tIf forces and velocities present KE will be calculated assuming\n" + "\tvelocities are a half step ahead of forces; if only velocities\n" + "\tpresent KE will be calculated assuming velocities are on-step.\n"); + else if (KEtype_ == KE_VV) + mprintf("\tKE will be calculated assuming velocities are a half step ahead of forces.\n"); + else if (KEtype_ == KE_VEL) + mprintf("\tKE will be calculated assuming velocities are on-step.\n"); + if (KEtype_ != KE_VEL) + mprintf("\tTime step for KE calculation if forces present: %g ps\n", dt_); } return Action::OK; } @@ -204,20 +319,43 @@ Action::RetType Action_Energy::Setup(ActionSetup& setup) { Mask1_.MaskInfo(); Imask_ = AtomMask(Mask1_.ConvertToIntMask(), Mask1_.Natom()); // Check for LJ terms - for (calc_it calc = Ecalcs_.begin(); calc != Ecalcs_.end(); ++calc) - if ((*calc == N14 || *calc == NBD) && !setup.Top().Nonbond().HasNonbond()) - { - mprinterr("Error: Nonbonded energy calc requested but topology '%s'\n" - "Error: does not have non-bonded parameters.\n", setup.Top().c_str()); + if (need_lj_params_ && !setup.Top().Nonbond().HasNonbond()) + { + mprinterr("Error: LJ energy calc requested but topology '%s'\n" + "Error: does not have LJ parameters.\n", setup.Top().c_str()); + return Action::ERR; + } + // Set up Ewald if necessary. + if (elecType_ == EWALD) { + if (((Ewald_Regular*)EW_)->Init(setup.CoordInfo().TrajBox(), cutoff_, dsumtol_, rsumtol_, + ewcoeff_, maxexp_, skinnb_, erfcDx_, debug_, mlimits_)) return Action::ERR; + EW_->Setup( setup.Top(), Imask_ ); + } + // For KE, check for velocities/forces + if (KEtype_ != KE_NONE) { + if (!setup.CoordInfo().HasVel()) { + mprintf("Warning: Coordinates have no velocities - kinetic energy will be zero.\n"); + } else if (KEtype_ == KE_AUTO) { + if (setup.CoordInfo().HasForce()) + mprintf("\tForce info present. Assuming plus-half time step velocities.\n" + "\tVelocities at time 't' will be estimated using force info.\n"); + else + mprintf("\tForce info not present. Assuming velocities are at same time\n" + "\tstep as coordinates.\n"); + } else if (KEtype_ == KE_VV && !setup.CoordInfo().HasForce()) { + mprintf("Warning: Coordinates have velocities but no forces - cannot use\n" + "Warning: 'ketype vv' to estimate kinetic energy.\n"); } - // Set up Ewald if necessary. - if (etype_ == EW) { // TODO erfc table dx option - if (EW_.EwaldInit(setup.CoordInfo().TrajBox(), cutoff_, dsumtol_, rsumtol_, - ewcoeff_, maxexp_, skinnb_, 0.0, debug_, mlimits_)) + } +# ifdef LIBPME + else if (elecType_ == PME) { + if (((Ewald_ParticleMesh*)EW_)->Init(setup.CoordInfo().TrajBox(), cutoff_, dsumtol_, + ewcoeff_, skinnb_, erfcDx_, npoints_, debug_, mlimits_)) return Action::ERR; - EW_.EwaldSetup( setup.Top(), Imask_ ); + EW_->Setup( setup.Top(), Imask_ ); } +# endif currentParm_ = setup.TopAddress(); return Action::OK; } @@ -240,74 +378,129 @@ double Action_Energy::Dbg_Direct(Frame const& frameIn, int maxpoints) { // Action_Energy::DoAction() Action::RetType Action_Energy::DoAction(int frameNum, ActionFrame& frm) { - etime_.Start(); + time_total_.Start(); double Etot = 0.0, ene, ene2; + typedef std::vector::const_iterator calc_it; for (calc_it calc = Ecalcs_.begin(); calc != Ecalcs_.end(); ++calc) { switch (*calc) { - case BND: + case C_BND: + time_bond_.Start(); ene = ENE_.E_bond(frm.Frm(), *currentParm_, Mask1_); + time_bond_.Stop(); Energy_[BOND]->Add(frameNum, &ene); Etot += ene; break; - case ANG: + case C_ANG: + time_angle_.Start(); ene = ENE_.E_angle(frm.Frm(), *currentParm_, Mask1_); + time_angle_.Stop(); Energy_[ANGLE]->Add(frameNum, &ene); Etot += ene; break; - case DIH: + case C_DIH: + time_tors_.Start(); ene = ENE_.E_torsion(frm.Frm(), *currentParm_, Mask1_); + time_tors_.Stop(); Energy_[DIHEDRAL]->Add(frameNum, &ene); Etot += ene; break; - case N14: + case C_N14: + time_14_.Start(); ene = ENE_.E_14_Nonbond(frm.Frm(), *currentParm_, Mask1_, ene2); - Energy_[V14]->Add(frameNum, &ene); - Energy_[Q14]->Add(frameNum, &ene2); + time_14_.Stop(); + if (Energy_[V14] != 0) Energy_[V14]->Add(frameNum, &ene); + if (Energy_[Q14] != 0) Energy_[Q14]->Add(frameNum, &ene2); Etot += (ene + ene2); break; - case NBD: + case C_NBD: // Both nonbond terms must be enabled + time_NB_.Start(); ene = ENE_.E_Nonbond(frm.Frm(), *currentParm_, Imask_, ene2); + time_NB_.Stop(); Energy_[VDW]->Add(frameNum, &ene); Energy_[ELEC]->Add(frameNum, &ene2); Etot += (ene + ene2); break; - case LJ: + case C_LJ: + time_NB_.Start(); ene = ENE_.E_VDW(frm.Frm(), *currentParm_, Imask_); + time_NB_.Stop(); Energy_[VDW]->Add(frameNum, &ene); Etot += ene; break; - case COULOMB: + case C_COULOMB: + time_NB_.Start(); ene = ENE_.E_Elec(frm.Frm(), *currentParm_, Imask_); + time_NB_.Stop(); Energy_[ELEC]->Add(frameNum, &ene); Etot += ene; break; - case DIRECT: + case C_DIRECT: + time_NB_.Start(); if (npoints_ < 0) ene = Dbg_Direct(frm.Frm(), (-npoints_)+1); else ene = ENE_.E_DirectSum(frm.Frm(), *currentParm_, Imask_, npoints_); + time_NB_.Stop(); Energy_[ELEC]->Add(frameNum, &ene); Etot += ene; break; - case EWALD: - ene = EW_.CalcEnergy(frm.Frm(), Imask_); + case C_EWALD: + case C_PME: // Elec must be enabled, vdw may not be + time_NB_.Start(); + ene = EW_->CalcEnergy(frm.Frm(), Imask_, ene2); + time_NB_.Stop(); Energy_[ELEC]->Add(frameNum, &ene); - Etot += ene; + if (Energy_[VDW] != 0) Energy_[VDW]->Add(frameNum, &ene2); + Etot += (ene + ene2); + break; + case C_KEAUTO: + if (frm.Frm().HasVelocity()) { + time_ke_.Start(); + if (frm.Frm().HasForce()) + ene = ENE_.E_Kinetic_VV(frm.Frm(), Imask_, dt_); + else + ene = ENE_.E_Kinetic(frm.Frm(), Imask_); + time_ke_.Stop(); + Energy_[KE]->Add(frameNum, &ene); + } + break; + case C_KEVEL: + time_ke_.Start(); + ene = ENE_.E_Kinetic(frm.Frm(), Imask_); + time_ke_.Stop(); + Energy_[KE]->Add(frameNum, &ene); + break; + case C_KEVV: + time_ke_.Start(); + ene = ENE_.E_Kinetic_VV(frm.Frm(), Imask_, dt_); + time_ke_.Stop(); + Energy_[KE]->Add(frameNum, &ene); break; } } - - Energy_[TOTAL]->Add(frameNum, &Etot); - etime_.Stop(); + if (Energy_[TOTAL] != 0) + Energy_[TOTAL]->Add(frameNum, &Etot); + time_total_.Stop(); return Action::OK; } void Action_Energy::Print() { - mprintf("Timing for energy: '%s' ('%s')\n", Energy_[TOTAL]->legend(), - Mask1_.MaskString()); - etime_.WriteTiming(0, " Total:"); - ENE_.PrintTiming(etime_.Total()); - if (etype_ == EW) - EW_.Timing(etime_.Total()); + mprintf("Timing for energy: '%s' ('%s')\n", setname_.c_str(), Mask1_.MaskString()); + time_total_.WriteTiming(0, " Total:"); + if (time_bond_.Total() > 0.0) + time_bond_.WriteTiming(1, "BOND :", time_total_.Total()); + if (time_angle_.Total() > 0.0) + time_angle_.WriteTiming(1, "ANGLE :", time_total_.Total()); + if (time_tors_.Total() > 0.0) + time_tors_.WriteTiming(1, "TORSION :", time_total_.Total()); + if (time_14_.Total() > 0.0) + time_14_.WriteTiming(1, "1-4_NONBOND :", time_total_.Total()); + if (time_NB_.Total() > 0.0) { + time_NB_.WriteTiming(1, "NONBOND :", time_total_.Total()); + if (elecType_ == EWALD || elecType_ == PME) + EW_->Timing(time_NB_.Total()); + } + if (time_ke_.Total() > 0.0) + time_ke_.WriteTiming(1, "KE :", time_total_.Total()); } diff --git a/src/Action_Energy.h b/src/Action_Energy.h index e27a47c473..668a7acdd3 100644 --- a/src/Action_Energy.h +++ b/src/Action_Energy.h @@ -7,6 +7,7 @@ class Action_Energy: public Action { public: Action_Energy(); + ~Action_Energy(); DispatchObject* Alloc() const { return (DispatchObject*)new Action_Energy(); } void Help() const; private: @@ -15,34 +16,47 @@ class Action_Energy: public Action { Action::RetType DoAction(int, ActionFrame&); void Print(); /// Corresponds to data sets. - enum Etype { BOND = 0, ANGLE, DIHEDRAL, V14, Q14, VDW, ELEC, TOTAL}; + enum Etype { BOND = 0, ANGLE, DIHEDRAL, V14, Q14, VDW, ELEC, KE, TOTAL}; /// Add energy data set of specified type. int AddSet(Etype, DataSetList&, DataFile*, std::string const&); /// For debugging the direct sum convergence double Dbg_Direct(Frame const&,int); /// Corresponds to calculations. - enum CalcType { BND, ANG, DIH, N14, NBD, LJ, COULOMB, DIRECT, EWALD }; + enum CalcType { C_BND = 0, C_ANG, C_DIH, C_N14, C_NBD, C_LJ, + C_COULOMB, C_DIRECT, C_EWALD, C_PME, C_KEAUTO, C_KEVEL, C_KEVV }; /// Corresponds to type of electrostatics. - enum ElecType { SIMPLE, DIRECTSUM, EW }; + enum ElecType { NO_ELE = 0, SIMPLE, DIRECTSUM, EWALD, PME }; + /// Corresponds to type of KE calc. + enum KEType { KE_NONE = 0, KE_AUTO, KE_VEL, KE_VV }; - ElecType etype_; ///< Type of electrostatics calc. - std::vector Energy_; ///< Hold output data sets + ElecType elecType_; ///< Type of electrostatics calc. + KEType KEtype_; ///< Type of KE calc. + std::vector Energy_; ///< Hold output data sets (length Etype+1) std::vector Ecalcs_; ///< Hold which calcs to perform - typedef std::vector::const_iterator calc_it; Topology* currentParm_; ///< Hold current topology CharMask Mask1_; ///< Char mask for all but NB calc AtomMask Imask_; ///< Int mask for NB calc Energy_Amber ENE_; ///< Energy calc class. - int npoints_; ///< # unit cells in each direction for elec. direct sum + std::string setname_; ///< Output DataSet name + int npoints_; ///< # cells in each direction (DIRECT) or spline order (PME) int debug_; - Ewald EW_; ///< Ewald energy class. - double cutoff_; ///< Ewald cutoff. + Ewald* EW_; ///< Ewald energy class. + double cutoff_; ///< Ewald direct space cutoff. double dsumtol_; ///< Ewald direct sum tolerance. - double rsumtol_; ///< Ewald reciprocal sum tolerance. + double rsumtol_; ///< Regular Ewald reciprocal sum tolerance. double ewcoeff_; ///< Ewald coefficient. double maxexp_; double skinnb_; ///< Size of non-bonded "skin" - int mlimits_[3]; - Timer etime_; + double erfcDx_; ///< Spacing for ERFC table (default 1/5000) + double dt_; ///< Time step for estimating kinetic energy (leapfrog) + int mlimits_[3]; ///< mlimits (reg. Ewald) or nfft (PME) + bool need_lj_params_; ///< True if LJ parameters needed. + Timer time_total_; + Timer time_bond_; + Timer time_angle_; + Timer time_tors_; + Timer time_14_; + Timer time_NB_; + Timer time_ke_; }; #endif diff --git a/src/Cpptraj.cpp b/src/Cpptraj.cpp index 06a1f45701..387118094b 100644 --- a/src/Cpptraj.cpp +++ b/src/Cpptraj.cpp @@ -197,6 +197,9 @@ std::string Cpptraj::Defines() { #endif #if defined(USE_SANDERLIB) && !defined(LIBCPPTRAJ) defined_str.append(" -DUSE_SANDERLIB"); +#endif +#ifdef LIBPME + defined_str.append(" -DLIBPME"); #endif return defined_str; } diff --git a/src/Energy.cpp b/src/Energy.cpp index 88ced199d6..2e6d72883a 100644 --- a/src/Energy.cpp +++ b/src/Energy.cpp @@ -13,11 +13,9 @@ Energy_Amber::Energy_Amber() : debug_(0) {} /** Bond energy */ double Energy_Amber::E_bond(Frame const& fIn, Topology const& tIn, CharMask const& mask) { - time_bond_.Start(); // Heavy atom bonds double Ebond = CalcBondEnergy(fIn, tIn.Bonds(), tIn.BondParm(), mask); Ebond += CalcBondEnergy(fIn, tIn.BondsH(), tIn.BondParm(), mask); - time_bond_.Stop(); return Ebond; } @@ -55,11 +53,9 @@ double Energy_Amber::CalcBondEnergy(Frame const& fIn, BondArray const& Bonds, /** Angle energy */ double Energy_Amber::E_angle(Frame const& fIn, Topology const& tIn, CharMask const& mask) { - time_angle_.Start(); // Heavy atom angles double Eang = CalcAngleEnergy(fIn, tIn.Angles(), tIn.AngleParm(), mask); Eang += CalcAngleEnergy(fIn, tIn.AnglesH(), tIn.AngleParm(), mask); - time_angle_.Stop(); return Eang; } @@ -99,11 +95,9 @@ double Energy_Amber::CalcAngleEnergy(Frame const& fIn, AngleArray const& Angles, /** Dihedral energy */ double Energy_Amber::E_torsion(Frame const& fIn, Topology const& tIn, CharMask const& mask) { - time_tors_.Start(); // Heavy atom dihedrals double Edih = CalcTorsionEnergy(fIn, tIn.Dihedrals(), tIn.DihedralParm(), mask); Edih += CalcTorsionEnergy(fIn, tIn.DihedralsH(), tIn.DihedralParm(), mask); - time_tors_.Stop(); return Edih; } @@ -147,12 +141,10 @@ double Energy_Amber::CalcTorsionEnergy(Frame const& fIn, DihedralArray const& Di double Energy_Amber::E_14_Nonbond(Frame const& fIn, Topology const& tIn, CharMask const& mask, double& Eq14) { - time_14_.Start(); Eq14 = 0.0; // Heavy atom dihedrals double Evdw14 = Calc_14_Energy(fIn, tIn.Dihedrals(), tIn.DihedralParm(), tIn, mask, Eq14); Evdw14 += Calc_14_Energy(fIn, tIn.DihedralsH(), tIn.DihedralParm(), tIn, mask, Eq14); - time_14_.Stop(); return Evdw14; } @@ -208,7 +200,6 @@ double Energy_Amber::Calc_14_Energy(Frame const& fIn, DihedralArray const& Dihed double Energy_Amber::E_Nonbond(Frame const& fIn, Topology const& tIn, AtomMask const& mask, double& EelecOut) { - time_NB_.Start(); double Evdw = 0.0; double Eelec = 0.0; int idx1; @@ -262,14 +253,12 @@ double Energy_Amber::E_Nonbond(Frame const& fIn, Topology const& tIn, AtomMask c } // END omp parallel # endif EelecOut = Eelec; - time_NB_.Stop(); return Evdw; } // ----------------------------------------------------------------------------- double Energy_Amber::E_VDW(Frame const& fIn, Topology const& tIn, AtomMask const& mask) { - time_NB_.Start(); double Evdw = 0.0; int idx1; # ifdef _OPENMP @@ -313,14 +302,12 @@ double Energy_Amber::E_VDW(Frame const& fIn, Topology const& tIn, AtomMask const # ifdef _OPENMP } // END omp parallel # endif - time_NB_.Stop(); return Evdw; } // ----------------------------------------------------------------------------- double Energy_Amber::E_Elec(Frame const& fIn, Topology const& tIn, AtomMask const& mask) { - time_NB_.Start(); double Eelec = 0.0; int idx1; # ifdef _OPENMP @@ -361,14 +348,12 @@ double Energy_Amber::E_Elec(Frame const& fIn, Topology const& tIn, AtomMask cons # ifdef _OPENMP } // END omp parallel # endif - time_NB_.Stop(); return Eelec; } // ----------------------------------------------------------------------------- double Energy_Amber::E_DirectSum(Frame const& fIn, Topology const& tIn, AtomMask const& mask, int n_points) { - time_NB_.Start(); // Direct sum double Edirect = E_Elec(fIn, tIn, mask); // Sum over images. @@ -408,15 +393,65 @@ double Energy_Amber::E_DirectSum(Frame const& fIn, Topology const& tIn, AtomMask } } // atom j } // atom i - time_NB_.Stop(); return Edirect + (Eimage/2.0); } // ----------------------------------------------------------------------------- -void Energy_Amber::PrintTiming(double totalIn) const { - time_bond_.WriteTiming(1, "BOND: ", totalIn); - time_angle_.WriteTiming(1, "ANGLE: ", totalIn); - time_tors_.WriteTiming(1, "TORSION: ", totalIn); - time_14_.WriteTiming(1, "1-4_NONBOND", totalIn); - time_NB_.WriteTiming(1, "NONBOND: ", totalIn); +/** Calculate the kinetic energy using given velocities. */ +double Energy_Amber::E_Kinetic(Frame const& fIn, AtomMask const& mask) +{ + if (!fIn.HasVelocity()) return 0.0; + double ke = 0.0; + for (AtomMask::const_iterator at = mask.begin(); at != mask.end(); ++at) + { + const double* vxyz = fIn.VelXYZ( *at ); + //mprintf("DEBUG: Atom %i vxyz = %12.4f %12.4f %12.4f\n", *at+1, vxyz[0], vxyz[1], vxyz[2]); + double v2 = vxyz[0]*vxyz[0] + vxyz[1]*vxyz[1] + vxyz[2]*vxyz[2]; + ke += (fIn.Mass(*at) * v2); + } + return 0.5 * ke; +} + +/** Calculate the kinetic energy assuming a Velocity Verlet / leapfrog scheme, + * i.e. the given velocities are one half step ahead of the given coordinates + * and forces. + * \param fIn Current frame with coordinates, +0.5*dt velocities, and forces. + * \param mask Selected atoms. + * \param dt Time step in ps. + */ +double Energy_Amber::E_Kinetic_VV(Frame const& fIn, AtomMask const& mask, double dt) +{ + // Vn = Vh - 0.5 * dt * Fn/m + // V = velocity, F = force, n = step, h = n + half step, dt = time step, m = mass + if (!fIn.HasVelocity() || !fIn.HasForce()) return 0.0; + double ke = 0.0; + double dthalf = dt * Constants::AMBERTIME_TO_PS * 0.5; + Vec3 velN(0.0); + for (AtomMask::const_iterator at = mask.begin(); at != mask.end(); ++at) + { + const double* vxyz = fIn.VelXYZ( *at ); + double mass = fIn.Mass( *at ); + //const double* fxyz = fIn.FrcXYZ( *at ); + Vec3 fxyz = Vec3(fIn.FrcXYZ(*at)); + velN[0] = vxyz[0] - dthalf * fxyz[0] / mass; + velN[1] = vxyz[1] - dthalf * fxyz[1] / mass; + velN[2] = vxyz[2] - dthalf * fxyz[2] / mass; + // DEBUG + /* + if (at == mask.begin()) { + double vold[3]; + for (int i = 0; i < 3; i++) { + vold[i] = vxyz[i] - (dt*Constants::AMBERTIME_TO_PS) * fxyz[i] / tIn[*at].Mass(); + mprintf("DBG: v vold m %6i%12.7f%12.7f%12.7f\n", i+1, vxyz[i], vold[i], tIn[*at].Mass()); + } + mprintf("\n"); + } + */ + ke += (mass * velN.Magnitude2()); + //for (int i = 0; i != 3; i++) { + // double v2 = (vxyz[i] + vold[i]); + // ke += (tIn[*at].Mass() * 0.25 * (v2 * v2)); + //} + } + return 0.5 * ke; } diff --git a/src/Energy.h b/src/Energy.h index dae6a43dd8..5b027a2bcc 100644 --- a/src/Energy.h +++ b/src/Energy.h @@ -1,7 +1,6 @@ #ifndef INC_ENERGY_H #define INC_ENERGY_H #include "Topology.h" -#include "Timer.h" /// Calculate energy/force from coordinates. class Energy_Amber { public: @@ -17,10 +16,12 @@ class Energy_Amber { double E_Elec(Frame const&, Topology const&, AtomMask const&); double E_DirectSum(Frame const&, Topology const&, AtomMask const&, int); - + /// Calculate kinetic energy from velocity information. + double E_Kinetic(Frame const&, AtomMask const&); + /// Calculate kinetic energy from forces and plus-half timestep velocities. + double E_Kinetic_VV(Frame const&, AtomMask const&, double); void SetDebug(int d) { debug_ = d; } - void PrintTiming(double) const; private: double CalcBondEnergy(Frame const&, BondArray const&, BondParmArray const&, CharMask const&); @@ -33,10 +34,5 @@ class Energy_Amber { static const double QFAC; int debug_; - Timer time_bond_; - Timer time_angle_; - Timer time_tors_; - Timer time_14_; - Timer time_NB_; }; #endif diff --git a/src/Ewald.cpp b/src/Ewald.cpp index d44a1875ae..50537f115a 100644 --- a/src/Ewald.cpp +++ b/src/Ewald.cpp @@ -1,30 +1,24 @@ -#include -#include // std::min, std::max +#include //sqrt #include "Ewald.h" #include "CpptrajStdio.h" #include "Constants.h" -#include "StringRoutines.h" +#include "StringRoutines.h" // ByteString #include "Spline.h" -#ifdef _OPENMP -# include +#ifdef DEBUG_PAIRLIST +#incl ude "PDBfile.h" #endif +/// CONSTRUCTOR Ewald::Ewald() : sumq_(0.0), sumq2_(0.0), ew_coeff_(0.0), - maxexp_(0.0), cutoff_(0.0), dsumTol_(0.0), - rsumTol_(0.0), erfcTableDx_(0.0), one_over_Dx_(0.0), - maxmlim_(0), debug_(0) { - mlimit_[0] = 0; - mlimit_[1] = 0; - mlimit_[2] = 0; # ifdef DEBUG_EWALD // Save fractional translations for 1 cell in each direction (and primary cell). // This is only for the non-pairlist version of direct. @@ -38,9 +32,6 @@ Ewald::Ewald() : const double Ewald::INVSQRTPI_ = 1.0 / sqrt(Constants::PI); -static inline double DABS(double xIn) { if (xIn < 0.0) return -xIn; else return xIn; } -static inline int IABS(int xIn) { if (xIn < 0 ) return -xIn; else return xIn; } - /** Complimentary error function: 2/sqrt(PI) * SUM[exp(-t^2)*dt] * Original code: SANDER: erfcfun.F90 */ @@ -93,6 +84,46 @@ double Ewald::erfc_func(double xIn) { return erfc; } +// Ewald::FillErfcTable() +void Ewald::FillErfcTable(double cutoffIn, double dxdr) { + one_over_Dx_ = 1.0 / erfcTableDx_; + unsigned int erfcTableSize = (unsigned int)(dxdr * one_over_Dx_ * cutoffIn * 1.5); + Darray erfc_X, erfc_Y; + erfc_X.reserve( erfcTableSize ); + erfc_Y.reserve( erfcTableSize ); + // Save X and Y values so we can calc the spline coefficients + double xval = 0.0; + for (unsigned int i = 0; i != erfcTableSize; i++) { + double yval = erfc_func( xval ); + erfc_X.push_back( xval ); + erfc_Y.push_back( yval ); + xval += erfcTableDx_; + } + Spline cspline; + cspline.CubicSpline_Coeff(erfc_X, erfc_Y); + erfc_X.clear(); + // Store values in Spline table + erfc_table_.reserve( erfcTableSize * 4 ); // Y B C D + for (unsigned int i = 0; i != erfcTableSize; i++) { + erfc_table_.push_back( erfc_Y[i] ); + erfc_table_.push_back( cspline.B_coeff()[i] ); + erfc_table_.push_back( cspline.C_coeff()[i] ); + erfc_table_.push_back( cspline.D_coeff()[i] ); + } + // Memory saved Y values plus spline B, C, and D coefficient arrays. + mprintf("\tMemory used by Erfc table and splines: %s\n", + ByteString(erfc_table_.size() * sizeof(double), BYTE_DECIMAL).c_str()); +} + +// Ewald::ERFC() +double Ewald::ERFC(double xIn) const { + int xidx = ((int)(one_over_Dx_ * xIn)); + double dx = xIn - ((double)xidx * erfcTableDx_); + xidx *= 4; + return erfc_table_[xidx] + + dx*(erfc_table_[xidx+1] + dx*(erfc_table_[xidx+2] + dx*erfc_table_[xidx+3])); +} + /** Determine Ewald coefficient from cutoff and direct sum tolerance. * Original Code: SANDER: findewaldcof */ @@ -128,135 +159,73 @@ double Ewald::FindEwaldCoefficient(double cutoff, double dsum_tol) return xval; } -/** \return maxexp value based on mlimits */ -double Ewald::FindMaxexpFromMlim(const int* mlimit, Matrix_3x3 const& recip) { - double maxexp = DABS( (double)mlimit[0] * recip[0] ); - double z2 = DABS( (double)mlimit[1] * recip[4] ); - maxexp = std::max(maxexp, z2); - double z3 = DABS( (double)mlimit[2] * recip[8] ); - maxexp = std::max(maxexp, z3); - return maxexp; -} - -/** \return maxexp value based on Ewald coefficient and reciprocal sum tolerance. */ -double Ewald::FindMaxexpFromTol(double ewCoeff, double rsumTol) { - double xval = 0.5; - int nloop = 0; - double term = 0.0; - do { - xval = 2.0 * xval; - nloop++; - double yval = Constants::PI * xval / ewCoeff; - term = 2.0 * ewCoeff * erfc_func(yval) * INVSQRTPI_; - } while (term >= rsumTol); - - // Binary search tolerance is 2^-60 - int ntimes = nloop + 60; - double xlo = 0.0; - double xhi = xval; - for (int i = 0; i != ntimes; i++) { - xval = (xlo + xhi) / 2.0; - double yval = Constants::PI * xval / ewCoeff; - double term = 2.0 * ewCoeff * erfc_func(yval) * INVSQRTPI_; - if (term > rsumTol) - xlo = xval; - else - xhi = xval; +/** Convert charges to Amber units. Calculate sum of charges and squared charges. */ +void Ewald::CalculateCharges(Topology const& topIn, AtomMask const& maskIn) { + sumq_ = 0.0; + sumq2_ = 0.0; + Charge_.clear(); + TypeIndices_.clear(); + for (AtomMask::const_iterator atom = maskIn.begin(); atom != maskIn.end(); ++atom) { + double qi = topIn[*atom].Charge() * Constants::ELECTOAMBER; + Charge_.push_back(qi); + sumq_ += qi; + sumq2_ += (qi * qi); + // Store atom type indices for selected atoms. + TypeIndices_.push_back( topIn[*atom].TypeIndex() ); } - mprintf("\tMaxExp for Ewald coefficient %g, direct sum tol %g is %g\n", - ewCoeff, rsumTol, xval); - return xval; + //mprintf("DEBUG: sumq= %20.10f sumq2= %20.10f\n", sumq_, sumq2_); + Setup_VDW_Correction( topIn, maskIn ); } -/** Get mlimits. */ -void Ewald::GetMlimits(int* mlimit, double maxexp, double eigmin, - Vec3 const& reclng, Matrix_3x3 const& recip) +/** Set up exclusion lists for selected atoms. */ +void Ewald::SetupExcluded(Topology const& topIn, AtomMask const& maskIn) { - //mprintf("DEBUG: Recip lengths %12.4f%12.4f%12.4f\n", reclng[0], reclng[1], reclng[2]); - - int mtop1 = (int)(reclng[0] * maxexp / sqrt(eigmin)); - int mtop2 = (int)(reclng[1] * maxexp / sqrt(eigmin)); - int mtop3 = (int)(reclng[2] * maxexp / sqrt(eigmin)); - - int nrecvecs = 0; - mlimit[0] = 0; - mlimit[1] = 0; - mlimit[2] = 0; - double maxexp2 = maxexp * maxexp; - for (int m1 = -mtop1; m1 <= mtop1; m1++) { - for (int m2 = -mtop2; m2 <= mtop2; m2++) { - for (int m3 = -mtop3; m3 <= mtop3; m3++) { - Vec3 Zvec = recip.TransposeMult( Vec3(m1,m2,m3) ); - if ( Zvec.Magnitude2() <= maxexp2 ) { - nrecvecs++; - mlimit[0] = std::max( mlimit[0], IABS(m1) ); - mlimit[1] = std::max( mlimit[1], IABS(m2) ); - mlimit[2] = std::max( mlimit[2], IABS(m3) ); - } + Excluded_.clear(); + Excluded_.resize( maskIn.Nselected() ); + // Create a character mask so we can see if atoms in excluded lists are + // also selected. + CharMask Cmask(maskIn.ConvertToCharMask(), maskIn.Nselected()); + // Create a map of atom number to maskIn index. + int selectedIdx = 0; + Iarray atToIdx( Cmask.Natom(), -1 ); + for (int cidx = 0; cidx != Cmask.Natom(); cidx++) + if (Cmask.AtomInCharMask(cidx)) + atToIdx[cidx] = selectedIdx++; + // Loop over selected atoms + for (int idx = 0; idx != maskIn.Nselected(); idx++) + { + // Always exclude self + Excluded_[idx].insert( idx ); + int at = maskIn[idx]; + for (Atom::excluded_iterator excluded_atom = topIn[at].excludedbegin(); + excluded_atom != topIn[at].excludedend(); + ++excluded_atom) + { + if (Cmask.AtomInCharMask(*excluded_atom)) + { + // Find excluded atoms index in maskIn + int excluded_idx = atToIdx[*excluded_atom]; + Excluded_[idx ].insert( excluded_idx ); + Excluded_[excluded_idx].insert( idx ); } } } - mprintf("\tNumber of reciprocal vectors: %i\n", nrecvecs); -} - -// Ewald::FillErfcTable() -void Ewald::FillErfcTable(double cutoffIn, double dxdr) { - one_over_Dx_ = 1.0 / erfcTableDx_; - unsigned int erfcTableSize = (unsigned int)(dxdr * one_over_Dx_ * cutoffIn * 1.5); - Darray erfc_X, erfc_Y; - erfc_X.reserve( erfcTableSize ); - erfc_Y.reserve( erfcTableSize ); - // Save X and Y values so we can calc the spline coefficients - double xval = 0.0; - for (unsigned int i = 0; i != erfcTableSize; i++) { - double yval = erfc_func( xval ); - erfc_X.push_back( xval ); - erfc_Y.push_back( yval ); - xval += erfcTableDx_; - } - Spline cspline; - cspline.CubicSpline_Coeff(erfc_X, erfc_Y); - erfc_X.clear(); - // Store values in Spline table - erfc_table_.reserve( erfcTableSize * 4 ); // Y B C D - for (unsigned int i = 0; i != erfcTableSize; i++) { - erfc_table_.push_back( erfc_Y[i] ); - erfc_table_.push_back( cspline.B_coeff()[i] ); - erfc_table_.push_back( cspline.C_coeff()[i] ); - erfc_table_.push_back( cspline.D_coeff()[i] ); - } - // Memory saved Y values plus spline B, C, and D coefficient arrays. - mprintf("\tMemory used by Erfc table and splines: %s\n", - ByteString(erfc_table_.size() * sizeof(double), BYTE_DECIMAL).c_str()); -} - -// Ewald::ERFC() -double Ewald::ERFC(double xIn) const { - int xidx = ((int)(one_over_Dx_ * xIn)); - double dx = xIn - ((double)xidx * erfcTableDx_); - xidx *= 4; - return erfc_table_[xidx] + - dx*(erfc_table_[xidx+1] + dx*(erfc_table_[xidx+2] + dx*erfc_table_[xidx+3])); + unsigned int ex_size = 0; + for (Iarray2D::const_iterator it = Excluded_.begin(); it != Excluded_.end(); ++it) + ex_size += it->size(); + mprintf("\tMemory used by full exclusion list: %s\n", + ByteString(ex_size * sizeof(int), BYTE_DECIMAL).c_str()); } -// ----------------------------------------------------------------------------- -/** Set up parameters. */ -int Ewald::EwaldInit(Box const& boxIn, double cutoffIn, double dsumTolIn, double rsumTolIn, - double ew_coeffIn, double maxexpIn, double skinnbIn, - double erfcTableDxIn, int debugIn, const int* mlimitsIn) +/** Check some common input. */ +int Ewald::CheckInput(Box const& boxIn, int debugIn, double cutoffIn, double dsumTolIn, + double ew_coeffIn, double erfcTableDxIn, double skinnbIn) { debug_ = debugIn; cutoff_ = cutoffIn; dsumTol_ = dsumTolIn; - rsumTol_ = rsumTolIn; ew_coeff_ = ew_coeffIn; - maxexp_ = maxexpIn; erfcTableDx_ = erfcTableDxIn; - Matrix_3x3 ucell, recip; - boxIn.ToRecip(ucell, recip); - if (mlimitsIn != 0) - std::copy(mlimitsIn, mlimitsIn+3, mlimit_); - // Check input if (cutoff_ < Constants::SMALL) { mprinterr("Error: Direct space cutoff (%g) is too small.\n", cutoff_); @@ -270,17 +239,6 @@ int Ewald::EwaldInit(Box const& boxIn, double cutoffIn, double dsumTolIn, double return 1; } } - if (mlimit_[0] < 0 || mlimit_[1] < 0 || mlimit_[2] < 0) { - mprinterr("Error: Cannot specify negative mlimit values.\n"); - return 1; - } - maxmlim_ = mlimit_[0]; - maxmlim_ = std::max(maxmlim_, mlimit_[1]); - maxmlim_ = std::max(maxmlim_, mlimit_[2]); - if (maxexp_ < 0.0) { - mprinterr("Error: maxexp is less than 0.0\n"); - return 1; - } if (skinnbIn < 0.0) { mprinterr("Error: skinnb is less than 0.0\n"); return 1; @@ -289,131 +247,37 @@ int Ewald::EwaldInit(Box const& boxIn, double cutoffIn, double dsumTolIn, double // Set defaults if necessary if (dsumTol_ < Constants::SMALL) dsumTol_ = 1E-5; - if (rsumTol_ < Constants::SMALL) - rsumTol_ = 5E-5; - Vec3 recipLengths = boxIn.RecipLengths(recip); if (DABS(ew_coeff_) < Constants::SMALL) ew_coeff_ = FindEwaldCoefficient( cutoff_, dsumTol_ ); - if (maxmlim_ > 0) - maxexp_ = FindMaxexpFromMlim(mlimit_, recip); - else { - if ( maxexp_ < Constants::SMALL ) - maxexp_ = FindMaxexpFromTol(ew_coeff_, rsumTol_); - // eigmin typically bigger than this unless cell is badly distorted. - double eigmin = 0.5; - // Calculate lengths of reciprocal vectors - GetMlimits(mlimit_, maxexp_, eigmin, recipLengths, recip); - maxmlim_ = mlimit_[0]; - maxmlim_ = std::max(maxmlim_, mlimit_[1]); - maxmlim_ = std::max(maxmlim_, mlimit_[2]); - } if (erfcTableDx_ <= 0.0) erfcTableDx_ = 1.0 / 5000; // TODO make this optional FillErfcTable( cutoff_, ew_coeff_ ); - mprintf("\tEwald params:\n"); - mprintf("\t Cutoff= %g Direct Sum Tol= %g Ewald coeff.= %g\n", - cutoff_, dsumTol_, ew_coeff_); - mprintf("\t MaxExp= %g Recip. Sum Tol= %g NB skin= %g\n", - maxexp_, rsumTol_, skinnbIn); - mprintf("\t Erfc table dx= %g, size= %zu\n", erfcTableDx_, erfc_table_.size()/4); - mprintf("\t mlimits= {%i,%i,%i} Max=%i\n", mlimit_[0], mlimit_[1], mlimit_[2], maxmlim_); - // Set up pair list - if (pairList_.InitPairList(cutoff_, skinnbIn, debugIn)) return 1; - if (pairList_.SetupPairList( boxIn.Type(), recipLengths )) return 1; - return 0; } -/** Convert charges to Amber units. Calculate sum of charges and squared charges. */ -void Ewald::EwaldSetup(Topology const& topIn, AtomMask const& maskIn) { - sumq_ = 0.0; - sumq2_ = 0.0; - Charge_.clear(); - for (AtomMask::const_iterator atom = maskIn.begin(); atom != maskIn.end(); ++atom) { - double qi = topIn[*atom].Charge() * Constants::ELECTOAMBER; - Charge_.push_back(qi); - sumq_ += qi; - sumq2_ += (qi * qi); - } - //mprintf("DEBUG: sumq= %20.10f sumq2= %20.10f\n", sumq_, sumq2_); - // Build exponential factors for use in structure factors. - // These arrays are laid out in 1D; value for each atom at each m, i.e. - // A0M0 A1M0 A2M0 ... ANM0 A0M1 ... ANMX - // Number of M values is the max + 1. - int mmax = maxmlim_ + 1; - unsigned int tsize = maskIn.Nselected() * mmax; - cosf1_.assign( tsize, 1.0 ); - cosf2_.assign( tsize, 1.0 ); - cosf3_.assign( tsize, 1.0 ); - sinf1_.assign( tsize, 0.0 ); - sinf2_.assign( tsize, 0.0 ); - sinf3_.assign( tsize, 0.0 ); - mprintf("\tMemory used by trig tables: %s\n", - ByteString(6*tsize*sizeof(double), BYTE_DECIMAL).c_str()); - // M0 -// for (int i = 0; i != maskIn.Nselected(); i++) { -// cosf1_.push_back( 1.0 ); -// cosf2_.push_back( 1.0 ); -// cosf3_.push_back( 1.0 ); -// sinf1_.push_back( 0.0 ); -// sinf2_.push_back( 0.0 ); -// sinf3_.push_back( 0.0 ); -// } - // Set up full exclusion lists. - Excluded_.clear(); - Excluded_.resize( topIn.Natom() ); - for (int at = 0; at != topIn.Natom(); at++) { - // Always exclude self - Excluded_[at].insert( at ); - for (Atom::excluded_iterator excluded_atom = topIn[at].excludedbegin(); - excluded_atom != topIn[at].excludedend(); - ++excluded_atom) - { - Excluded_[at ].insert( *excluded_atom ); - Excluded_[*excluded_atom].insert( at ); - } - } - unsigned int ex_size = 0; - for (Iarray2D::const_iterator it = Excluded_.begin(); it != Excluded_.end(); ++it) - ex_size += it->size(); - mprintf("\tMemory used by full exclusion list: %s\n", - ByteString(ex_size * sizeof(int), BYTE_DECIMAL).c_str()); -# ifdef _OPENMP - // Pre-calculate m1 and m2 indices - mlim1_.clear(); - mlim2_.clear(); - multCut_ = 0; - for (int m1 = 0; m1 <= mlimit_[0]; m1++) { - for (int m2 = -mlimit_[1]; m2 <= mlimit_[1]; m2++) { - mlim1_.push_back( m1 ); - mlim2_.push_back( m2 ); - } - // After this index (end of m1 == 0) multiplier must be 2.0 - if (m1 == 0) - multCut_ = (int)mlim1_.size(); - } - // Each thread will need its own space for trig math - int numthreads; -# pragma omp parallel - { -# pragma omp master - { - numthreads = omp_get_num_threads(); - mprintf("\tParallelizing calculation with %i threads\n", numthreads); - } - } - unsigned int asize = (unsigned int)maskIn.Nselected() * (unsigned int)numthreads; - c12_.resize( asize ); - s12_.resize( asize ); - c3_.resize( asize ); - s3_.resize( asize ); -#else - c12_.resize( maskIn.Nselected() ); - s12_.resize( maskIn.Nselected() ); - c3_.resize( maskIn.Nselected() ); - s3_.resize( maskIn.Nselected() ); +/** Initialize and set up pairlist. */ +int Ewald::Setup_Pairlist(Box const& boxIn, Vec3 const& recipLengths, double skinnbIn) { + if (pairList_.InitPairList(cutoff_, skinnbIn, debug_)) return 1; + if (pairList_.SetupPairList( boxIn.Type(), recipLengths )) return 1; +# ifdef DEBUG_PAIRLIST + // Write grid PDB + PDBfile gridpdb; + Matrix_3x3 ucell, recip; + boxIn.ToRecip(ucell, recip); + gridpdb.OpenWrite("gridpoints.pdb"); + for (int iz = 0; iz != pairList_.NZ(); iz++) + for (int iy = 0; iy != pairList_.NY(); iy++) + for (int ix = 0; ix != pairList_.NX(); ix++) { + double fx = (double)ix / (double)pairList_.NX(); + double fy = (double)iy / (double)pairList_.NY(); + double fz = (double)iz / (double)pairList_.NZ(); + Vec3 cart = ucell.TransposeMult( Vec3(fx,fy,fz) ); + gridpdb.WriteHET(1, cart[0], cart[1], cart[2]); + } + gridpdb.CloseFile(); # endif + return 0; } /** Self energy. This is the cancelling Gaussian plus the "neutralizing plasma". */ @@ -429,158 +293,6 @@ double Ewald::Self(double volume) { return ene; } -/** Reciprocal space energy counteracting the neutralizing charge distribution. */ -double Ewald::Recip_Regular(Matrix_3x3 const& recip, double volume) { - t_recip_.Start(); - double fac = (Constants::PI*Constants::PI) / (ew_coeff_ * ew_coeff_); - double maxexp2 = maxexp_ * maxexp_; - double ene = 0.0; - Varray const& Frac = pairList_.FracCoords(); - // Number of M values is the max + 1. - int mmax = maxmlim_ + 1; - // Build exponential factors for use in structure factors. - // These arrays are laid out in 1D; value for each atom at each m, i.e. - // A0M0 A1M0 A2M0 ... ANM0 A0M1 ... ANMX - // M0 is done in EwaldSetup() - t_trig_tables_.Start(); - unsigned int mnidx = Frac.size(); - // M1 - for (unsigned int i = 0; i != Frac.size(); i++, mnidx++) { - //mprintf("FRAC: %6i%20.10f%20.10f%20.10f\n", i+1, Frac[i][0], Frac[i][1], Frac[i][2]); - cosf1_[mnidx] = cos(Constants::TWOPI * Frac[i][0]); - cosf2_[mnidx] = cos(Constants::TWOPI * Frac[i][1]); - cosf3_[mnidx] = cos(Constants::TWOPI * Frac[i][2]); - sinf1_[mnidx] = sin(Constants::TWOPI * Frac[i][0]); - sinf2_[mnidx] = sin(Constants::TWOPI * Frac[i][1]); - sinf3_[mnidx] = sin(Constants::TWOPI * Frac[i][2]); - } - // M2-MX - // Get the higher factors by recursion using trig addition rules. - // Negative values of M by complex conjugation, or even cosf, odd sinf. - // idx will always point to M-1 values - unsigned int idx = Frac.size(); - for (int m = 2; m < mmax; m++) { - // Set m1idx to beginning of M1 values. - unsigned int m1idx = Frac.size(); - for (unsigned int i = 0; i != Frac.size(); i++, idx++, m1idx++, mnidx++) { - cosf1_[mnidx] = cosf1_[idx]*cosf1_[m1idx] - sinf1_[idx]*sinf1_[m1idx]; - cosf2_[mnidx] = cosf2_[idx]*cosf2_[m1idx] - sinf2_[idx]*sinf2_[m1idx]; - cosf3_[mnidx] = cosf3_[idx]*cosf3_[m1idx] - sinf3_[idx]*sinf3_[m1idx]; - sinf1_[mnidx] = sinf1_[idx]*cosf1_[m1idx] + cosf1_[idx]*sinf1_[m1idx]; - sinf2_[mnidx] = sinf2_[idx]*cosf2_[m1idx] + cosf2_[idx]*sinf2_[m1idx]; - sinf3_[mnidx] = sinf3_[idx]*cosf3_[m1idx] + cosf3_[idx]*sinf3_[m1idx]; - } - } - // DEBUG -/* unsigned int midx = 0; - for (int m = 0; m != mmax; m++) { - for (unsigned int i = 0; i != Frac.size(); i++, midx++) - mprintf("TRIG: %6i%6u%12.6f%12.6f%12.6f%12.6f%12.6f%12.6f\n", m,i+1, - cosf1_[midx], cosf2_[midx], cosf3_[midx], - sinf1_[midx], sinf2_[midx], sinf3_[midx]); - }*/ - t_trig_tables_.Stop(); -# ifdef _OPENMP - double mult; - unsigned int offset; - int mlim_idx; - int mlim_end = (int)mlim1_.size(); - double *c12, *s12, *c3, *s3; -# pragma omp parallel private(mult,mlim_idx,c12,s12,c3,s3,offset) reduction(+:ene) - { - offset = (unsigned int)omp_get_thread_num() * Frac.size(); - c12 = &c12_[0] + offset; - s12 = &s12_[0] + offset; - c3 = &c3_[0] + offset; - s3 = &s3_[0] + offset; -# pragma omp for - for (mlim_idx = 0; mlim_idx < mlim_end; mlim_idx++) - { - if (mlim_idx < multCut_) - mult = 1.0; - else - mult = 2.0; - int m1 = mlim1_[mlim_idx]; - int m2 = mlim2_[mlim_idx]; -# else - Darray& c12 = c12_; - Darray& s12 = s12_; - Darray& c3 = c3_; - Darray& s3 = s3_; - double mult = 1.0; - for (int m1 = 0; m1 <= mlimit_[0]; m1++) - { - for (int m2 = -mlimit_[1]; m2 <= mlimit_[1]; m2++) - { -# endif - int m1idx = Frac.size() * m1; - int m2idx = Frac.size() * IABS(m2); - - if (m2 < 0) { - for (unsigned int i = 0; i != Frac.size(); i++, m1idx++, m2idx++) { - c12[i] = cosf1_[m1idx]*cosf2_[m2idx] + sinf1_[m1idx]*sinf2_[m2idx]; - s12[i] = sinf1_[m1idx]*cosf2_[m2idx] - cosf1_[m1idx]*sinf2_[m2idx]; - } - } else { - for (unsigned int i = 0; i != Frac.size(); i++, m1idx++, m2idx++) { - c12[i] = cosf1_[m1idx]*cosf2_[m2idx] - sinf1_[m1idx]*sinf2_[m2idx]; - s12[i] = sinf1_[m1idx]*cosf2_[m2idx] + cosf1_[m1idx]*sinf2_[m2idx]; - } - } - for (int m3 = -mlimit_[2]; m3 <= mlimit_[2]; m3++) - { - // Columns of recip are reciprocal unit cell vecs, so - // mhat contains Cartesian components of recip vector M. - Vec3 mhat = recip.TransposeMult( Vec3(m1, m2, m3) ); - double msq = mhat.Magnitude2(); - double denom = Constants::PI * volume * msq; - double eterm = 0.0; -// double vterm = 0.0; - if ( m1*m1 + m2*m2 + m3*m3 > 0 ) { - eterm = exp(-fac*msq) / denom; -// vterm = 2.0 * (fac*msq + 1.0) / msq; - } - // mult takes care to double count for symmetry. Can take care of - // with eterm. - eterm *= mult; - if (msq < maxexp2) { - int m3idx = Frac.size() * IABS(m3); - // Get the product of complex exponentials. - if (m3 < 0) { - for (unsigned int i = 0; i != Frac.size(); i++, m3idx++) { - c3[i] = c12[i]*cosf3_[m3idx] + s12[i]*sinf3_[m3idx]; - s3[i] = s12[i]*cosf3_[m3idx] - c12[i]*sinf3_[m3idx]; - } - } else { - for (unsigned int i = 0; i != Frac.size(); i++, m3idx++) { - c3[i] = c12[i]*cosf3_[m3idx] - s12[i]*sinf3_[m3idx]; - s3[i] = s12[i]*cosf3_[m3idx] + c12[i]*sinf3_[m3idx]; - } - } - // Get the structure factor - double cstruct = 0.0; - double sstruct = 0.0; - for (unsigned int i = 0; i != Frac.size(); i++) { - cstruct += Charge_[i] * c3[i]; - sstruct += Charge_[i] * s3[i]; - } - double struc2 = cstruct*cstruct + sstruct*sstruct; - ene += eterm * struc2; - //mprintf("LOOP: %3i%3i%3i ENE= %20.10f\n", m1, m2, m3, ene); - } // END IF msq < maxexp2 - } // END loop over m3 -# ifdef _OPENMP - } // END loop over mlim_idx - } // END pragma omp parallel -# else - } // END loop over m2 - mult = 2.0; - } // END loop over m1 -# endif - t_recip_.Stop(); - return ene * 0.5; -} - // Ewald::Adjust() # ifdef _OPENMP double Ewald::Adjust(double q0, double q1, double rij) const { @@ -606,15 +318,16 @@ double Ewald::Adjust(double q0, double q1, double rij) { * a pair list. Also calculate the energy adjustment for excluded * atoms. */ -double Ewald::Direct(PairList const& PL, double& e_adjust_out) +double Ewald::Direct(PairList const& PL, double& e_adjust_out, double& evdw_out) { t_direct_.Start(); double cut2 = cutoff_ * cutoff_; double Eelec = 0.0; double e_adjust = 0.0; + double Evdw = 0.0; int cidx; # ifdef _OPENMP -# pragma omp parallel private(cidx) reduction(+: Eelec, e_adjust) +# pragma omp parallel private(cidx) reduction(+: Eelec, Evdw, e_adjust) { # pragma omp for # endif @@ -633,6 +346,9 @@ double Ewald::Direct(PairList const& PL, double& e_adjust_out) { Vec3 const& xyz0 = it0->ImageCoords(); double q0 = Charge_[it0->Idx()]; +# ifdef DEBUG_PAIRLIST + mprintf("DBG: Cell %6i (%6i atoms):\n", cidx+1, thisCell.NatomsInGrid()); +# endif // Exclusion list for this atom Iset const& excluded = Excluded_[it0->Idx()]; // Calc interaction of atom to all other atoms in thisCell. @@ -643,6 +359,9 @@ double Ewald::Direct(PairList const& PL, double& e_adjust_out) double q1 = Charge_[it1->Idx()]; Vec3 dxyz = xyz1 - xyz0; double rij2 = dxyz.Magnitude2(); +# ifdef DEBUG_PAIRLIST + mprintf("\tAtom %6i to atom %6i (%f)\n", it0->Idx()+1, it1->Idx()+1, sqrt(rij2)); +# endif // If atom excluded, calc adjustment, otherwise calc elec. energy. if (excluded.find( it1->Idx() ) == excluded.end()) { @@ -660,12 +379,25 @@ double Ewald::Direct(PairList const& PL, double& e_adjust_out) double e_elec = qiqj * erfc / rij; Eelec += e_elec; //int ta0, ta1; - //if (atnum0 < atnum1) { - // ta0=atnum0; ta1=atnum1; + //if (it0->Idx() < it1->Idx()) { + // ta0=it0->Idx(); ta1=it1->Idx(); //} else { - // ta1=atnum0; ta0=atnum1; + // ta1=it0->Idx(); ta0=it1->Idx(); //} //mprintf("PELEC %6i%6i%12.5f%12.5f%12.5f\n", ta0, ta1, rij, erfc, e_elec); + int nbindex = NB_->GetLJindex(TypeIndices_[it0->Idx()], + TypeIndices_[it1->Idx()]); + if (nbindex > -1) { + NonbondType const& LJ = NB_->NBarray()[ nbindex ]; + double r2 = 1.0 / rij2; + double r6 = r2 * r2 * r2; + double r12 = r6 * r6; + double f12 = LJ.A() * r12; // A/r^12 + double f6 = LJ.B() * r6; // B/r^6 + double e_vdw = f12 - f6; // (A/r^12)-(B/r^6) + Evdw += e_vdw; + //mprintf("PVDW %8i%8i%20.6f%20.6f\n", ta0+1, ta1+1, e_vdw, r2); + } } } else e_adjust += Adjust(q0, q1, sqrt(rij2)); @@ -674,6 +406,9 @@ double Ewald::Direct(PairList const& PL, double& e_adjust_out) for (unsigned int nidx = 1; nidx != cellList.size(); nidx++) { PairList::CellType const& nbrCell = PL.Cell( cellList[nidx] ); +# ifdef DEBUG_PAIRLIST + if (nbrCell.NatomsInGrid()>0) mprintf("\tto neighbor cell %6i\n", cellList[nidx]+1); +# endif // Translate vector for neighbor cell Vec3 const& tVec = PL.TransVec( transList[nidx] ); //mprintf("\tNEIGHBOR %i (idxs %i - %i)\n", nbrCell, beg1, end1); @@ -685,6 +420,9 @@ double Ewald::Direct(PairList const& PL, double& e_adjust_out) double q1 = Charge_[it1->Idx()]; Vec3 dxyz = xyz1 + tVec - xyz0; double rij2 = dxyz.Magnitude2(); +# ifdef DEBUG_PAIRLIST + mprintf("\t\tAtom %6i to atom %6i (%f)\n", it0->Idx()+1, it1->Idx()+1, sqrt(rij2)); +# endif //mprintf("\t\tNbrAtom %06i\n",atnum1); // If atom excluded, calc adjustment, otherwise calc elec. energy. // TODO Is there better way of checking this? @@ -706,12 +444,25 @@ double Ewald::Direct(PairList const& PL, double& e_adjust_out) Eelec += e_elec; //mprintf("EELEC %4i%4i%12.5f%12.5f%12.5f%3.0f%3.0f%3.0f\n", //int ta0, ta1; - //if (atnum0 < atnum1) { - // ta0=atnum0; ta1=atnum1; + //if (it0->Idx() < it1->Idx()) { + // ta0=it0->Idx(); ta1=it1->Idx(); //} else { - // ta1=atnum0; ta0=atnum1; + // ta1=it0->Idx(); ta0=it1->Idx(); //} //mprintf("PELEC %6i%6i%12.5f%12.5f%12.5f\n", ta0, ta1, rij, erfc, e_elec); + int nbindex = NB_->GetLJindex(TypeIndices_[it0->Idx()], + TypeIndices_[it1->Idx()]); + if (nbindex > -1) { + NonbondType const& LJ = NB_->NBarray()[ nbindex ]; + double r2 = 1.0 / rij2; + double r6 = r2 * r2 * r2; + double r12 = r6 * r6; + double f12 = LJ.A() * r12; // A/r^12 + double f6 = LJ.B() * r6; // B/r^6 + double e_vdw = f12 - f6; // (A/r^12)-(B/r^6) + Evdw += e_vdw; + //mprintf("PVDW %8i%8i%20.6f%20.6f\n", ta0+1, ta1+1, e_vdw, r2); + } } } else e_adjust += Adjust(q0, q1, sqrt(rij2)); @@ -725,28 +476,47 @@ double Ewald::Direct(PairList const& PL, double& e_adjust_out) # endif t_direct_.Stop(); e_adjust_out = e_adjust; + evdw_out = Evdw; return Eelec; } -/** Calculate Ewald energy. Faster version that uses pair list. */ -double Ewald::CalcEnergy(Frame const& frameIn, AtomMask const& maskIn) -{ - t_total_.Start(); - Matrix_3x3 ucell, recip; - double volume = frameIn.BoxCrd().ToRecip(ucell, recip); - double e_self = Self( volume ); - - pairList_.CreatePairList(frameIn, ucell, recip, maskIn); +/** Determine VDW long range correction prefactor. */ +void Ewald::Setup_VDW_Correction(Topology const& topIn, AtomMask const& maskIn) { + Vdw_Recip_term_ = 0.0; + NB_ = static_cast( &(topIn.Nonbond()) ); + if (!NB_->HasNonbond()) { + mprintf("Warning: '%s' has no nonbonded parameters. Cannot calculate VDW correction.\n"); + return; + } + // Count the number of each unique nonbonded type. + Iarray N_vdw_type( NB_->Ntypes(), 0 ); + for (AtomMask::const_iterator atm = maskIn.begin(); atm != maskIn.end(); ++atm) + N_vdw_type[ topIn[*atm].TypeIndex() ]++; + if (debug_ > 0) { + mprintf("DEBUG: %zu VDW types.\n", N_vdw_type.size()); + for (Iarray::const_iterator it = N_vdw_type.begin(); it != N_vdw_type.end(); ++it) + mprintf("\tType %u = %i\n", it-N_vdw_type.begin(), *it); + } + // Determine correction term from types and LJ B parameters + for (unsigned int itype = 0; itype != N_vdw_type.size(); itype++) + { + unsigned int offset = N_vdw_type.size() * itype; + for (unsigned int jtype = 0; jtype != N_vdw_type.size(); jtype++) + { + unsigned int idx = offset + jtype; + int nbidx = NB_->NBindex()[ idx ]; + if (nbidx > -1) + Vdw_Recip_term_ += N_vdw_type[itype] * N_vdw_type[jtype] * NB_->NBarray()[ nbidx ].B(); + } + } +} -// MapCoords(frameIn, ucell, recip, maskIn); - double e_recip = Recip_Regular( recip, volume ); - double e_adjust = 0.0; - double e_direct = Direct( pairList_, e_adjust ); - if (debug_ > 0) - mprintf("DEBUG: Eself= %20.10f Erecip= %20.10f Edirect= %20.10f Eadjust= %20.10f\n", - e_self, e_recip, e_direct, e_adjust); - t_total_.Stop(); - return e_self + e_recip + e_direct + e_adjust; +/** Calculate full VDW long range correction from volume. */ +double Ewald::Vdw_Correction(double volume) { + double prefac = Constants::TWOPI / (3.0*volume*cutoff_*cutoff_*cutoff_); + double e_vdwr = -prefac * Vdw_Recip_term_; + if (debug_ > 0) mprintf("DEBUG: Vdw correction %20.10f\n", e_vdwr); + return e_vdwr; } #ifdef DEBUG_EWALD @@ -835,11 +605,12 @@ double Ewald::CalcEnergy_NoPairList(Frame const& frameIn, Topology const& topIn, // Ewald::Timing() void Ewald::Timing(double total) const { - t_total_.WriteTiming(1, "EwaldTotal:", total); + t_total_.WriteTiming(1, " EwaldTotal:", total); t_self_.WriteTiming(2, "Self: ", t_total_.Total()); t_recip_.WriteTiming(2, "Recip: ", t_total_.Total()); - t_trig_tables_.WriteTiming(3, "Calc trig tables:", t_recip_.Total()); - t_direct_.WriteTiming(2, "Direct : ", t_total_.Total()); + if (t_trig_tables_.Total() > 0.0) + t_trig_tables_.WriteTiming(3, "Calc trig tables:", t_recip_.Total()); + t_direct_.WriteTiming(2, "Direct: ", t_total_.Total()); # ifndef _OPENMP t_erfc_.WriteTiming(3, "ERFC: ", t_direct_.Total()); t_adjust_.WriteTiming(3,"Adjust:", t_direct_.Total()); diff --git a/src/Ewald.h b/src/Ewald.h index 787a3eaed9..f4458c7974 100644 --- a/src/Ewald.h +++ b/src/Ewald.h @@ -3,94 +3,86 @@ #include "Topology.h" #include "Timer.h" #include "PairList.h" -/// Class for calculating electrostatics using Ewald summation. +/// Base class for calculating electrostatics using Ewald methods. class Ewald { public: Ewald(); - /// Initialize Ewald parameters. - int EwaldInit(Box const&, double, double, double, double, double, double, - double, int, const int*); - /// Set up for given topology and mask. - void EwaldSetup(Topology const&, AtomMask const&); - /// Calculate electrostatic energy via Ewald summation. - double CalcEnergy(Frame const&, AtomMask const&); + // ----- Virtual functions ------------------- + virtual ~Ewald() {} + virtual int Setup(Topology const&, AtomMask const&) = 0; + virtual double CalcEnergy(Frame const&, AtomMask const&, double&) = 0; // TODO const? + // ------------------------------------------- /// Report timings. void Timing(double) const; # ifdef DEBUG_EWALD /// Slow non-pairlist version of energy calc. For debug only. double CalcEnergy_NoPairList(Frame const&, Topology const&, AtomMask const&); # endif - private: + protected: + typedef std::vector Darray; + typedef std::vector Iarray; + typedef std::vector Varray; + typedef std::set Iset; + typedef std::vector Iarray2D; + + static inline double DABS(double xIn) { if (xIn < 0.0) return -xIn; else return xIn; } /// Complimentary error function, erfc. static double erfc_func(double); /// Determine Ewald coefficient from cutoff and direct sum tolerance. static double FindEwaldCoefficient(double,double); - /// Determine max length for reciprocal calcs based on reciprocal limits - static double FindMaxexpFromMlim(const int*, Matrix_3x3 const&); - /// Determine max length for reciprocal calcs based on Ewald coefficient and recip tol. - static double FindMaxexpFromTol(double, double); - /// Determine reciprocal limits based on unit cell reciprocal vectors - static void GetMlimits(int*, double, double, Vec3 const&, Matrix_3x3 const&); + /// Fill erfc lookup table using cubic spline interpolation. void FillErfcTable(double,double); /// \return erfc value from erfc lookup table. inline double ERFC(double) const; /// Ewald "self" energy double Self(double); - /// Ewald reciprocal energy - double Recip_Regular(Matrix_3x3 const&, double); + /// Get analytical estimate of energy due to dispersion interactions > cutoff + double Vdw_Correction(double); + /// Box, debug, cutoff, dsum tol, ew coeff, erfc dx, nb skin + int CheckInput(Box const&, int, double, double, double, double, double); + /// Set up pair list + int Setup_Pairlist(Box const&, Vec3 const&, double); + /// Calculate sum q, sum q^2. Calls setup for vdw correction + void CalculateCharges(Topology const&, AtomMask const&); + /// Setup main excluded atom list + void SetupExcluded(Topology const&, AtomMask const&); + /// Setup VDW correction for selected atom types + void Setup_VDW_Correction(Topology const&, AtomMask const&); + # ifdef DEBUG_EWALD /// Slow version of direct space energy, no pairlist. double Direct(Matrix_3x3 const&, Topology const&, AtomMask const&); # endif /// Fast version of direct space energy using a pairlist - double Direct(PairList const&, double&); + double Direct(PairList const&, double&, double&); /// \return adjusted energy for excluded atom pair # ifdef _OPENMP inline double Adjust(double,double,double) const; # else inline double Adjust(double,double,double); // Cannot be const bc timers # endif - typedef std::vector Darray; - typedef std::vector Varray; - typedef std::set Iset; - typedef std::vector Iarray2D; + + // TODO make variables private # ifdef DEBUG_EWALD Varray Cells_; ///< Hold fractional translations to neighbor cells (non-pairlist only) # endif - Darray Charge_; ///< Hold atomic charges converted to Amber units. - // Hold trig tables - Darray cosf1_; - Darray cosf2_; - Darray cosf3_; - Darray sinf1_; - Darray sinf2_; - Darray sinf3_; - Darray c12_; - Darray s12_; - Darray c3_; - Darray s3_; + Darray Charge_; ///< Hold selected atomic charges converted to Amber units. PairList pairList_; ///< Atom pair list for direct sum. Darray erfc_table_; ///< Hold Erfc cubic spline Y values and coefficients (Y B C D). - Iarray2D Excluded_; ///< Full exclusion list for each atom. -# ifdef _OPENMP - typedef std::vector Iarray; - Iarray mlim1_; ///< Hold m1 reciprocal indices - Iarray mlim2_; ///< Hold m2 reciprocal indices - int multCut_; ///< Hold index after which multiplier should be 2.0. -# endif + Iarray2D Excluded_; ///< Full exclusion list for each selected atom. + Iarray TypeIndices_; ///< Hold atom type indices for selected atoms + NonbondParmType const* NB_; ///< Pointer to nonbonded parameters + static const double INVSQRTPI_; double sumq_; ///< Sum of charges double sumq2_; ///< Sum of charges squared double ew_coeff_; ///< Ewald coefficient - double maxexp_; ///< Determines how far out recip vectors go? FIXME check! double cutoff_; ///< Direct space cutoff double dsumTol_; ///< Direct space sum tolerance. - double rsumTol_; ///< Reciprocal space sum tolerance. double erfcTableDx_; ///< Spacing of X values in Erfc table. double one_over_Dx_; ///< One over erfcTableDx_. - int mlimit_[3]; ///< Number of units in each direction to calc recip. sum. - int maxmlim_; ///< The max of the three mlimit_ values. + double Vdw_Recip_term_; ///< VDW recip correction term from # types and B parameters int debug_; Timer t_total_; Timer t_self_; diff --git a/src/Ewald_ParticleMesh.cpp b/src/Ewald_ParticleMesh.cpp new file mode 100644 index 0000000000..2c45acc849 --- /dev/null +++ b/src/Ewald_ParticleMesh.cpp @@ -0,0 +1,222 @@ +#ifdef LIBPME +#include // copy/fill +#include // unique_ptr +#include "Ewald_ParticleMesh.h" +#include "libpme_standalone.h" +#include "CpptrajStdio.h" + +typedef libpme::Matrix Mat; + +/// CONSTRUCTOR +Ewald_ParticleMesh::Ewald_ParticleMesh() : order_(6) +{ + nfft_[0] = -1; + nfft_[1] = -1; + nfft_[2] = -1; +} + +/** \return true if given number is a product of powers of 2, 3, or 5. */ +static inline bool check_prime_factors(int nIn) { + if (nIn == 1) return true; + int NL = nIn; + int NQ; + // First divide down by 2 + while (NL > 0) { + NQ = NL / 2; + if (NQ * 2 != NL) break; + if (NQ == 1) return true; + NL = NQ; + } + // Next try 3 + while (NL > 0) { + NQ = NL / 3; + if (NQ * 3 != NL) break; + if (NQ == 1) return true; + NL = NQ; + } + // Last try 5 + while (NL > 0) { + NQ = NL / 5; + if (NQ * 5 != NL) break; + if (NQ == 1) return true; + NL = NQ; + } + return false; +} + +/** Compute the ceiling of len that is also a product of powers of 2, 3, 5. + * Use check_prime_factors to get the smallest integer greater or equal + * than len which is decomposable into powers of 2, 3, 5. + */ +int Ewald_ParticleMesh::ComputeNFFT(double len) { + int mval = (int)len - 1; + for (int i = 0; i < 100; i++) { + mval += 1; + // Sanity check + if (mval < 1) { + mprinterr("Error: Bad box length %g, cannot get NFFT value.\n", len); + return 0; + } + if (check_prime_factors(mval)) + return mval; + } + mprinterr("Error: Failed to get good FFT array size for length %g Ang.\n", len); + return 0; +} + +/** Given a box, determine number of FFT grid points in each dimension. */ +int Ewald_ParticleMesh::DetermineNfft(int& nfft1, int& nfft2, int& nfft3, Box const& boxIn) const +{ + if (nfft1 < 1) { + // Need even dimension for X direction + nfft1 = ComputeNFFT( (boxIn.BoxX() + 1.0) * 0.5 ); + nfft1 *= 2; + } + if (nfft2 < 1) + nfft2 = ComputeNFFT( boxIn.BoxY() ); + if (nfft3 < 1) + nfft3 = ComputeNFFT( boxIn.BoxZ() ); + + if (nfft1 < 1 || nfft2 < 1 || nfft3 < 1) { + mprinterr("Error: Bad NFFT values: %i %i %i\n", nfft1, nfft2, nfft3); + return 1; + } + if (debug_ > 0) mprintf("DEBUG: NFFTs: %i %i %i\n", nfft1, nfft2, nfft3); + + return 0; +} + +/** Set up PME parameters. */ +int Ewald_ParticleMesh::Init(Box const& boxIn, double cutoffIn, double dsumTolIn, + double ew_coeffIn, double skinnbIn, double erfcTableDxIn, + int orderIn, int debugIn, const int* nfftIn) +{ + if (CheckInput(boxIn, debugIn, cutoffIn, dsumTolIn, ew_coeffIn, erfcTableDxIn, skinnbIn)) + return 1; + if (nfftIn != 0) + std::copy(nfftIn, nfftIn+3, nfft_); + else + std::fill(nfft_, nfft_+3, -1); + order_ = orderIn; + + // Set defaults if necessary + if (order_ < 1) order_ = 6; + + mprintf("\tParticle Mesh Ewald params:\n"); + mprintf("\t Cutoff= %g Direct Sum Tol= %g Ewald coeff.= %g NB skin= %g\n", + cutoff_, dsumTol_, ew_coeff_, skinnbIn); + mprintf("\t Bspline order= %i\n", order_); + mprintf("\t Erfc table dx= %g, size= %zu\n", erfcTableDx_, erfc_table_.size()/4); + mprintf("\t "); + for (int i = 0; i != 3; i++) + if (nfft_[i] == -1) + mprintf(" NFFT%i=auto", i+1); + else + mprintf(" NFFT%i=%i", i+1, nfft_[i]); + mprintf("\n"); + + // Set up pair list + Matrix_3x3 ucell, recip; + boxIn.ToRecip(ucell, recip); + Vec3 recipLengths = boxIn.RecipLengths(recip); + if (Setup_Pairlist(boxIn, recipLengths, skinnbIn)) return 1; + + return 0; +} + +/** Setup PME calculation. */ +int Ewald_ParticleMesh::Setup(Topology const& topIn, AtomMask const& maskIn) { + CalculateCharges(topIn, maskIn); + coordsD_.clear(); + coordsD_.reserve( maskIn.Nselected() * 3); + SetupExcluded(topIn, maskIn); + return 0; +} + +/* +static inline void PrintM(const char* Title, Mat const& M_) +{ + mprintf(" %s\n",Title); + mprintf(" %16.10f %16.10f %16.10f\n", M_(0,0), M_(0,1), M_(0,2)); + mprintf(" %16.10f %16.10f %16.10f\n", M_(1,0), M_(1,1), M_(1,2)); + mprintf(" %16.10f %16.10f %16.10f\n", M_(2,0), M_(2,1), M_(2,2)); +}*/ + +// Ewald::Recip_ParticleMesh() +double Ewald_ParticleMesh::Recip_ParticleMesh(Box const& boxIn) +{ + t_recip_.Start(); + // This essentially makes coordsD and chargesD point to arrays. + Mat coordsD(&coordsD_[0], Charge_.size(), 3); + Mat chargesD(&Charge_[0], Charge_.size(), 1); + int nfft1 = nfft_[0]; + int nfft2 = nfft_[1]; + int nfft3 = nfft_[2]; + if ( DetermineNfft(nfft1, nfft2, nfft3, boxIn) ) { + mprinterr("Error: Could not determine grid spacing.\n"); + return 0.0; + } + // Instantiate double precision PME object + // Args: 1 = Exponent of the distance kernel: 1 for Coulomb + // 2 = Kappa + // 3 = Spline order + // 4 = nfft1 + // 5 = nfft2 + // 6 = nfft3 + // 7 = scale factor to be applied to all computed energies and derivatives thereof + // 8 = max # threads to use for each MPI instance; 0 = all available threads used. + // NOTE: Scale factor for Charmm is 332.0716 + // NOTE: The electrostatic constant has been baked into the Charge_ array already. + auto pme_object = std::unique_ptr(new PMEInstanceD()); + pme_object->setup(1, ew_coeff_, order_, nfft1, nfft2, nfft3, 1.0, 0); + // Sets the unit cell lattice vectors, with units consistent with those used to specify coordinates. + // Args: 1 = the A lattice parameter in units consistent with the coordinates. + // 2 = the B lattice parameter in units consistent with the coordinates. + // 3 = the C lattice parameter in units consistent with the coordinates. + // 4 = the alpha lattice parameter in degrees. + // 5 = the beta lattice parameter in degrees. + // 6 = the gamma lattice parameter in degrees. + // 7 = lattice type + pme_object->setLatticeVectors(boxIn.BoxX(), boxIn.BoxY(), boxIn.BoxZ(), + boxIn.Alpha(), boxIn.Beta(), boxIn.Gamma(), + PMEInstanceD::LatticeType::XAligned); + double erecip = pme_object->computeERec(0, chargesD, coordsD); + t_recip_.Stop(); + return erecip; +} + +/** Calculate full nonbonded energy with PME */ +double Ewald_ParticleMesh::CalcEnergy(Frame const& frameIn, AtomMask const& maskIn, double& e_vdw) +{ + t_total_.Start(); + Matrix_3x3 ucell, recip; + double volume = frameIn.BoxCrd().ToRecip(ucell, recip); + double e_self = Self( volume ); + double e_vdwr = Vdw_Correction( volume ); + + pairList_.CreatePairList(frameIn, ucell, recip, maskIn); + + // TODO make more efficient + int idx = 0; + coordsD_.clear(); + for (AtomMask::const_iterator atm = maskIn.begin(); atm != maskIn.end(); ++atm, ++idx) { + const double* XYZ = frameIn.XYZ( *atm ); + coordsD_.push_back( XYZ[0] ); + coordsD_.push_back( XYZ[1] ); + coordsD_.push_back( XYZ[2] ); + } + +// MapCoords(frameIn, ucell, recip, maskIn); + double e_recip = Recip_ParticleMesh( frameIn.BoxCrd() ); + double e_adjust = 0.0; + e_vdw = 0.0; + double e_direct = Direct( pairList_, e_adjust, e_vdw ); + if (debug_ > 0) + mprintf("DEBUG: Eself= %20.10f Erecip= %20.10f Edirect= %20.10f Eadjust= %20.10f Evdw= %20.10f\n", + e_self, e_recip, e_direct, e_adjust, e_vdw); + e_vdw += e_vdwr; + t_total_.Stop(); + return e_self + e_recip + e_direct + e_adjust; +} + +#endif /* LIBPME */ diff --git a/src/Ewald_ParticleMesh.h b/src/Ewald_ParticleMesh.h new file mode 100644 index 0000000000..73c625bbf7 --- /dev/null +++ b/src/Ewald_ParticleMesh.h @@ -0,0 +1,29 @@ +#ifndef INC_EWALD_PARTICLEMESH_H +#define INC_EWALD_PARTICLEMESH_H +#ifdef LIBPME +#include "Ewald.h" +/// Class for calculating electrostatics with particle mesh Ewald. +class Ewald_ParticleMesh : public Ewald { + public: + Ewald_ParticleMesh(); + /// Box, cut, dsum tol, ew coeff, NB skin, erfc dx, order, debug, nfft + int Init(Box const&, double, double, double, double, double, int, int, const int*); + // ----- Inherited --------------------------- + int Setup(Topology const&, AtomMask const&); + double CalcEnergy(Frame const&, AtomMask const&, double&); // TODO const? + private: + typedef Ewald::Darray Darray; + /// Based on given length return number of grid points that is power of 2, 3, or 5 + static int ComputeNFFT(double); + /// Determine grid points for FFT in each dimension + int DetermineNfft(int&, int&, int&, Box const&) const; + /// Particle mesh Ewald reciprocal energy + double Recip_ParticleMesh(Box const&); + + Darray coordsD_; ///< Hold coordinates for selected atoms + + int nfft_[3]; ///< Number of FFT grid points in each direction + int order_; ///< PME B spline order +}; +#endif /* LIBPME */ +#endif diff --git a/src/Ewald_Regular.cpp b/src/Ewald_Regular.cpp new file mode 100644 index 0000000000..0a713040a6 --- /dev/null +++ b/src/Ewald_Regular.cpp @@ -0,0 +1,400 @@ +#include // copy/fill/min/max +#include +#include "Ewald_Regular.h" +#include "CpptrajStdio.h" +#include "Constants.h" +#include "StringRoutines.h" // ByteString +#ifdef _OPENMP +# include +#endif + +/// CONSTRUCTOR +Ewald_Regular::Ewald_Regular() : +# ifdef _OPENMP + multCut_(0), +# endif + maxexp_(0.0), + rsumTol_(0.0), + maxmlim_(0) +{ + mlimit_[0] = 0; + mlimit_[1] = 0; + mlimit_[2] = 0; +} + +/** \return maxexp value based on mlimits */ +double Ewald_Regular::FindMaxexpFromMlim(const int* mlimit, Matrix_3x3 const& recip) { + double maxexp = DABS( (double)mlimit[0] * recip[0] ); + double z2 = DABS( (double)mlimit[1] * recip[4] ); + maxexp = std::max(maxexp, z2); + double z3 = DABS( (double)mlimit[2] * recip[8] ); + maxexp = std::max(maxexp, z3); + return maxexp; +} + +/** \return maxexp value based on Ewald coefficient and reciprocal sum tolerance. */ +double Ewald_Regular::FindMaxexpFromTol(double ewCoeff, double rsumTol) { + double xval = 0.5; + int nloop = 0; + double term = 0.0; + do { + xval = 2.0 * xval; + nloop++; + double yval = Constants::PI * xval / ewCoeff; + term = 2.0 * ewCoeff * erfc_func(yval) * INVSQRTPI_; + } while (term >= rsumTol); + + // Binary search tolerance is 2^-60 + int ntimes = nloop + 60; + double xlo = 0.0; + double xhi = xval; + for (int i = 0; i != ntimes; i++) { + xval = (xlo + xhi) / 2.0; + double yval = Constants::PI * xval / ewCoeff; + double term = 2.0 * ewCoeff * erfc_func(yval) * INVSQRTPI_; + if (term > rsumTol) + xlo = xval; + else + xhi = xval; + } + mprintf("\tMaxExp for Ewald coefficient %g, direct sum tol %g is %g\n", + ewCoeff, rsumTol, xval); + return xval; +} + +static inline int IABS(int xIn) { if (xIn < 0 ) return -xIn; else return xIn; } + +/** Get mlimits. */ +void Ewald_Regular::GetMlimits(int* mlimit, double maxexp, double eigmin, + Vec3 const& reclng, Matrix_3x3 const& recip) +{ + //mprintf("DEBUG: Recip lengths %12.4f%12.4f%12.4f\n", reclng[0], reclng[1], reclng[2]); + + int mtop1 = (int)(reclng[0] * maxexp / sqrt(eigmin)); + int mtop2 = (int)(reclng[1] * maxexp / sqrt(eigmin)); + int mtop3 = (int)(reclng[2] * maxexp / sqrt(eigmin)); + + int nrecvecs = 0; + mlimit[0] = 0; + mlimit[1] = 0; + mlimit[2] = 0; + double maxexp2 = maxexp * maxexp; + for (int m1 = -mtop1; m1 <= mtop1; m1++) { + for (int m2 = -mtop2; m2 <= mtop2; m2++) { + for (int m3 = -mtop3; m3 <= mtop3; m3++) { + Vec3 Zvec = recip.TransposeMult( Vec3(m1,m2,m3) ); + if ( Zvec.Magnitude2() <= maxexp2 ) { + nrecvecs++; + mlimit[0] = std::max( mlimit[0], IABS(m1) ); + mlimit[1] = std::max( mlimit[1], IABS(m2) ); + mlimit[2] = std::max( mlimit[2], IABS(m3) ); + } + } + } + } + mprintf("\tNumber of reciprocal vectors: %i\n", nrecvecs); +} + +/** Init regular Ewald calculation. */ +int Ewald_Regular::Init(Box const& boxIn, double cutoffIn, double dsumTolIn, double rsumTolIn, + double ew_coeffIn, double maxexpIn, double skinnbIn, + double erfcTableDxIn, int debugIn, const int* mlimitsIn) +{ + if (CheckInput(boxIn, debugIn, cutoffIn, dsumTolIn, ew_coeffIn, erfcTableDxIn, skinnbIn)) + return 1; + rsumTol_ = rsumTolIn; + maxexp_ = maxexpIn; + Matrix_3x3 ucell, recip; + boxIn.ToRecip(ucell, recip); + if (mlimitsIn != 0) + std::copy(mlimitsIn, mlimitsIn+3, mlimit_); + else + std::fill(mlimit_, mlimit_+3, 0); + + // Check input + if (mlimit_[0] < 0 || mlimit_[1] < 0 || mlimit_[2] < 0) { + mprinterr("Error: Cannot specify negative mlimit values.\n"); + return 1; + } + maxmlim_ = mlimit_[0]; + maxmlim_ = std::max(maxmlim_, mlimit_[1]); + maxmlim_ = std::max(maxmlim_, mlimit_[2]); + if (maxexp_ < 0.0) { + mprinterr("Error: maxexp is less than 0.0\n"); + return 1; + } + + // Set defaults if necessary + if (rsumTol_ < Constants::SMALL) + rsumTol_ = 5E-5; + Vec3 recipLengths = boxIn.RecipLengths(recip); + if (maxmlim_ > 0) + maxexp_ = FindMaxexpFromMlim(mlimit_, recip); + else { + if ( maxexp_ < Constants::SMALL ) + maxexp_ = FindMaxexpFromTol(ew_coeff_, rsumTol_); + // eigmin typically bigger than this unless cell is badly distorted. + double eigmin = 0.5; + // Calculate lengths of reciprocal vectors + GetMlimits(mlimit_, maxexp_, eigmin, recipLengths, recip); + maxmlim_ = mlimit_[0]; + maxmlim_ = std::max(maxmlim_, mlimit_[1]); + maxmlim_ = std::max(maxmlim_, mlimit_[2]); + } + + mprintf("\tEwald params:\n"); + mprintf("\t Cutoff= %g Direct Sum Tol= %g Ewald coeff.= %g\n", + cutoff_, dsumTol_, ew_coeff_); + mprintf("\t MaxExp= %g Recip. Sum Tol= %g NB skin= %g\n", + maxexp_, rsumTol_, skinnbIn); + mprintf("\t Erfc table dx= %g, size= %zu\n", erfcTableDx_, erfc_table_.size()/4); + mprintf("\t mlimits= {%i,%i,%i} Max=%i\n", mlimit_[0], mlimit_[1], mlimit_[2], maxmlim_); + // Set up pair list + if (Setup_Pairlist(boxIn, recipLengths, skinnbIn)) return 1; + + return 0; +} + +/** Setup regular Ewald calculation. */ +int Ewald_Regular::Setup(Topology const& topIn, AtomMask const& maskIn) { + CalculateCharges(topIn, maskIn); + + // Build exponential factors for use in structure factors. + // These arrays are laid out in 1D; value for each atom at each m, i.e. + // A0M0 A1M0 A2M0 ... ANM0 A0M1 ... ANMX + // Number of M values is the max + 1. + int mmax = maxmlim_ + 1; + unsigned int tsize = maskIn.Nselected() * mmax; + cosf1_.assign( tsize, 1.0 ); + cosf2_.assign( tsize, 1.0 ); + cosf3_.assign( tsize, 1.0 ); + sinf1_.assign( tsize, 0.0 ); + sinf2_.assign( tsize, 0.0 ); + sinf3_.assign( tsize, 0.0 ); + mprintf("\tMemory used by trig tables: %s\n", + ByteString(6*tsize*sizeof(double), BYTE_DECIMAL).c_str()); + // M0 +// for (int i = 0; i != maskIn.Nselected(); i++) { +// cosf1_.push_back( 1.0 ); +// cosf2_.push_back( 1.0 ); +// cosf3_.push_back( 1.0 ); +// sinf1_.push_back( 0.0 ); +// sinf2_.push_back( 0.0 ); +// sinf3_.push_back( 0.0 ); +// } + + SetupExcluded(topIn, maskIn); + +# ifdef _OPENMP + // Pre-calculate m1 and m2 indices + mlim1_.clear(); + mlim2_.clear(); + multCut_ = 0; + for (int m1 = 0; m1 <= mlimit_[0]; m1++) { + for (int m2 = -mlimit_[1]; m2 <= mlimit_[1]; m2++) { + mlim1_.push_back( m1 ); + mlim2_.push_back( m2 ); + } + // After this index (end of m1 == 0) multiplier must be 2.0 + if (m1 == 0) + multCut_ = (int)mlim1_.size(); + } + // Each thread will need its own space for trig math + int numthreads; +# pragma omp parallel + { +# pragma omp master + { + numthreads = omp_get_num_threads(); + mprintf("\tParallelizing calculation with %i threads\n", numthreads); + } + } + unsigned int asize = (unsigned int)maskIn.Nselected() * (unsigned int)numthreads; + c12_.resize( asize ); + s12_.resize( asize ); + c3_.resize( asize ); + s3_.resize( asize ); +#else + c12_.resize( maskIn.Nselected() ); + s12_.resize( maskIn.Nselected() ); + c3_.resize( maskIn.Nselected() ); + s3_.resize( maskIn.Nselected() ); +# endif + return 0; +} + +/** Reciprocal space energy counteracting the neutralizing charge distribution. */ +double Ewald_Regular::Recip_Regular(Matrix_3x3 const& recip, double volume) { + t_recip_.Start(); + double fac = (Constants::PI*Constants::PI) / (ew_coeff_ * ew_coeff_); + double maxexp2 = maxexp_ * maxexp_; + double ene = 0.0; + Varray const& Frac = pairList_.FracCoords(); + // Number of M values is the max + 1. + int mmax = maxmlim_ + 1; + // Build exponential factors for use in structure factors. + // These arrays are laid out in 1D; value for each atom at each m, i.e. + // A0M0 A1M0 A2M0 ... ANM0 A0M1 ... ANMX + // M0 is done in EwaldSetup() + t_trig_tables_.Start(); + unsigned int mnidx = Frac.size(); + // M1 + for (unsigned int i = 0; i != Frac.size(); i++, mnidx++) { + //mprintf("FRAC: %6i%20.10f%20.10f%20.10f\n", i+1, Frac[i][0], Frac[i][1], Frac[i][2]); + cosf1_[mnidx] = cos(Constants::TWOPI * Frac[i][0]); + cosf2_[mnidx] = cos(Constants::TWOPI * Frac[i][1]); + cosf3_[mnidx] = cos(Constants::TWOPI * Frac[i][2]); + sinf1_[mnidx] = sin(Constants::TWOPI * Frac[i][0]); + sinf2_[mnidx] = sin(Constants::TWOPI * Frac[i][1]); + sinf3_[mnidx] = sin(Constants::TWOPI * Frac[i][2]); + } + // M2-MX + // Get the higher factors by recursion using trig addition rules. + // Negative values of M by complex conjugation, or even cosf, odd sinf. + // idx will always point to M-1 values + unsigned int idx = Frac.size(); + for (int m = 2; m < mmax; m++) { + // Set m1idx to beginning of M1 values. + unsigned int m1idx = Frac.size(); + for (unsigned int i = 0; i != Frac.size(); i++, idx++, m1idx++, mnidx++) { + cosf1_[mnidx] = cosf1_[idx]*cosf1_[m1idx] - sinf1_[idx]*sinf1_[m1idx]; + cosf2_[mnidx] = cosf2_[idx]*cosf2_[m1idx] - sinf2_[idx]*sinf2_[m1idx]; + cosf3_[mnidx] = cosf3_[idx]*cosf3_[m1idx] - sinf3_[idx]*sinf3_[m1idx]; + sinf1_[mnidx] = sinf1_[idx]*cosf1_[m1idx] + cosf1_[idx]*sinf1_[m1idx]; + sinf2_[mnidx] = sinf2_[idx]*cosf2_[m1idx] + cosf2_[idx]*sinf2_[m1idx]; + sinf3_[mnidx] = sinf3_[idx]*cosf3_[m1idx] + cosf3_[idx]*sinf3_[m1idx]; + } + } + // DEBUG +/* unsigned int midx = 0; + for (int m = 0; m != mmax; m++) { + for (unsigned int i = 0; i != Frac.size(); i++, midx++) + mprintf("TRIG: %6i%6u%12.6f%12.6f%12.6f%12.6f%12.6f%12.6f\n", m,i+1, + cosf1_[midx], cosf2_[midx], cosf3_[midx], + sinf1_[midx], sinf2_[midx], sinf3_[midx]); + }*/ + t_trig_tables_.Stop(); +# ifdef _OPENMP + double mult; + unsigned int offset; + int mlim_idx; + int mlim_end = (int)mlim1_.size(); + double *c12, *s12, *c3, *s3; +# pragma omp parallel private(mult,mlim_idx,c12,s12,c3,s3,offset) reduction(+:ene) + { + offset = (unsigned int)omp_get_thread_num() * Frac.size(); + c12 = &c12_[0] + offset; + s12 = &s12_[0] + offset; + c3 = &c3_[0] + offset; + s3 = &s3_[0] + offset; +# pragma omp for + for (mlim_idx = 0; mlim_idx < mlim_end; mlim_idx++) + { + if (mlim_idx < multCut_) + mult = 1.0; + else + mult = 2.0; + int m1 = mlim1_[mlim_idx]; + int m2 = mlim2_[mlim_idx]; +# else + Darray& c12 = c12_; + Darray& s12 = s12_; + Darray& c3 = c3_; + Darray& s3 = s3_; + double mult = 1.0; + for (int m1 = 0; m1 <= mlimit_[0]; m1++) + { + for (int m2 = -mlimit_[1]; m2 <= mlimit_[1]; m2++) + { +# endif + int m1idx = Frac.size() * m1; + int m2idx = Frac.size() * IABS(m2); + + if (m2 < 0) { + for (unsigned int i = 0; i != Frac.size(); i++, m1idx++, m2idx++) { + c12[i] = cosf1_[m1idx]*cosf2_[m2idx] + sinf1_[m1idx]*sinf2_[m2idx]; + s12[i] = sinf1_[m1idx]*cosf2_[m2idx] - cosf1_[m1idx]*sinf2_[m2idx]; + } + } else { + for (unsigned int i = 0; i != Frac.size(); i++, m1idx++, m2idx++) { + c12[i] = cosf1_[m1idx]*cosf2_[m2idx] - sinf1_[m1idx]*sinf2_[m2idx]; + s12[i] = sinf1_[m1idx]*cosf2_[m2idx] + cosf1_[m1idx]*sinf2_[m2idx]; + } + } + for (int m3 = -mlimit_[2]; m3 <= mlimit_[2]; m3++) + { + // Columns of recip are reciprocal unit cell vecs, so + // mhat contains Cartesian components of recip vector M. + Vec3 mhat = recip.TransposeMult( Vec3(m1, m2, m3) ); + double msq = mhat.Magnitude2(); + double denom = Constants::PI * volume * msq; + double eterm = 0.0; +// double vterm = 0.0; + if ( m1*m1 + m2*m2 + m3*m3 > 0 ) { + eterm = exp(-fac*msq) / denom; +// vterm = 2.0 * (fac*msq + 1.0) / msq; + } + // mult takes care to double count for symmetry. Can take care of + // with eterm. + eterm *= mult; + if (msq < maxexp2) { + int m3idx = Frac.size() * IABS(m3); + // Get the product of complex exponentials. + if (m3 < 0) { + for (unsigned int i = 0; i != Frac.size(); i++, m3idx++) { + c3[i] = c12[i]*cosf3_[m3idx] + s12[i]*sinf3_[m3idx]; + s3[i] = s12[i]*cosf3_[m3idx] - c12[i]*sinf3_[m3idx]; + } + } else { + for (unsigned int i = 0; i != Frac.size(); i++, m3idx++) { + c3[i] = c12[i]*cosf3_[m3idx] - s12[i]*sinf3_[m3idx]; + s3[i] = s12[i]*cosf3_[m3idx] + c12[i]*sinf3_[m3idx]; + } + } + // Get the structure factor + double cstruct = 0.0; + double sstruct = 0.0; + for (unsigned int i = 0; i != Frac.size(); i++) { + cstruct += Charge_[i] * c3[i]; + sstruct += Charge_[i] * s3[i]; + } + double struc2 = cstruct*cstruct + sstruct*sstruct; + ene += eterm * struc2; + //mprintf("LOOP: %3i%3i%3i ENE= %20.10f\n", m1, m2, m3, ene); + } // END IF msq < maxexp2 + } // END loop over m3 +# ifdef _OPENMP + } // END loop over mlim_idx + } // END pragma omp parallel +# else + } // END loop over m2 + mult = 2.0; + } // END loop over m1 +# endif + t_recip_.Stop(); + return ene * 0.5; +} + +/** Calculate Ewald energy. Faster version that uses pair list. */ +double Ewald_Regular::CalcEnergy(Frame const& frameIn, AtomMask const& maskIn, double& e_vdw) +{ + t_total_.Start(); + Matrix_3x3 ucell, recip; + double volume = frameIn.BoxCrd().ToRecip(ucell, recip); + double e_self = Self( volume ); + double e_vdwr = Vdw_Correction( volume ); + + pairList_.CreatePairList(frameIn, ucell, recip, maskIn); + +// MapCoords(frameIn, ucell, recip, maskIn); + double e_recip = Recip_Regular( recip, volume ); + double e_adjust = 0.0; + e_vdw = 0.0; + double e_direct = Direct( pairList_, e_adjust, e_vdw ); + if (debug_ > 0) + mprintf("DEBUG: Eself= %20.10f Erecip= %20.10f Edirect= %20.10f Eadjust= %20.10f Evdw= %20.10f\n", + e_self, e_recip, e_direct, e_adjust, e_vdw); + e_vdw += e_vdwr; + t_total_.Stop(); + return e_self + e_recip + e_direct + e_adjust; +} diff --git a/src/Ewald_Regular.h b/src/Ewald_Regular.h new file mode 100644 index 0000000000..e89fb103cb --- /dev/null +++ b/src/Ewald_Regular.h @@ -0,0 +1,47 @@ +#ifndef INC_EWALD_REGULAR_H +#define INC_EWALD_REGULAR_H +#include "Ewald.h" +/// Calculate regular Ewald energy +class Ewald_Regular : public Ewald { + public: + Ewald_Regular(); + /// Box, cutoff, dsum tol, rsum tol, ew coeff, maxexp, nb skin, erfc dx, debug, mlimits + int Init(Box const&, double, double, double, double, double, double, + double, int, const int*); + // ----- Inherited --------------------------- + int Setup(Topology const&, AtomMask const&); + double CalcEnergy(Frame const&, AtomMask const&, double&); // TODO const? + private: + /// Determine max length for reciprocal calcs based on reciprocal limits + static double FindMaxexpFromMlim(const int*, Matrix_3x3 const&); + /// Determine max length for reciprocal calcs based on Ewald coefficient and recip tol. + static double FindMaxexpFromTol(double, double); + /// Determine reciprocal limits based on unit cell reciprocal vectors + static void GetMlimits(int*, double, double, Vec3 const&, Matrix_3x3 const&); + /// Ewald reciprocal energy + double Recip_Regular(Matrix_3x3 const&, double); + + typedef Ewald::Darray Darray; + // Hold trig tables + Darray cosf1_; + Darray cosf2_; + Darray cosf3_; + Darray sinf1_; + Darray sinf2_; + Darray sinf3_; + Darray c12_; + Darray s12_; + Darray c3_; + Darray s3_; +# ifdef _OPENMP + typedef Ewald::Iarray Iarray; + Iarray mlim1_; ///< Hold m1 reciprocal indices + Iarray mlim2_; ///< Hold m2 reciprocal indices + int multCut_; ///< Hold index after which multiplier should be 2.0. +# endif + double maxexp_; ///< Determines how far out recip vectors go? FIXME check! + double rsumTol_; ///< Reciprocal space sum tolerance. + int mlimit_[3]; ///< Number of units in each direction to calc recip. sum. / nfft + int maxmlim_; ///< The max of the three mlimit_ values. / pme spline order +}; +#endif diff --git a/src/FindDepend.cpp b/src/FindDepend.cpp index a02ef84a22..d8c6d4a28e 100644 --- a/src/FindDepend.cpp +++ b/src/FindDepend.cpp @@ -14,7 +14,7 @@ using namespace std; #define BUFFERSIZE 1024 // Return true if first goes before second -bool compareNames( string first, string second) { +bool compareNames( string const& first, string const& second) { if ( first.compare(second) < 0) return true; else @@ -99,15 +99,15 @@ list *PeakHeader(char *filename, int indent, bool includeStdHeaders) { // DEBUG //fprintf(stdout,"%i:%s ",indent,filename); //for (it=HeaderList->begin(); it!=HeaderList->end(); it++) - // fprintf(stdout,"[%s]",(*it).c_str()); + // fprintf(stdout,"[%s]",it->c_str()); //fprintf(stdout,"\n"); // Go through each header in the list, skipping standard headers // Use a copy of HeaderList so the iterator wont go on forever SpliceList = *HeaderList; for (it=SpliceList.begin(); it!=SpliceList.end(); it++) { - if ( (*it).find('<')==string::npos ) { - SecondList = PeakHeader((char*)(*it).c_str(),indent+1,includeStdHeaders); + if ( it->find('<')==string::npos && *it != "libpme_standalone.h" ) { + SecondList = PeakHeader((char*)it->c_str(),indent+1,includeStdHeaders); if (SecondList!=NULL) { HeaderList->splice( HeaderList->end(), *SecondList ); delete SecondList; diff --git a/src/Makefile b/src/Makefile index fef1d8d111..d7623f33d4 100644 --- a/src/Makefile +++ b/src/Makefile @@ -21,8 +21,8 @@ install: $(INSTALL_TARGETS) install_cpptraj: cpptraj$(SFX)$(EXE) mv cpptraj$(SFX)$(EXE) $(CPPTRAJBIN) -cpptraj$(SFX)$(EXE): $(OBJECTS) $(FFT_DEPEND) $(READLINE_TARGET) $(CUDA_TARGET) $(XDRFILE_TARGET) - $(CXX) -o cpptraj$(SFX)$(EXE) $(OBJECTS) $(READLINE) $(CUDA_TARGET) $(FFT_LIB) $(CPPTRAJ_LIB) $(LDFLAGS) +cpptraj$(SFX)$(EXE): $(OBJECTS) $(FFT_TARGET) $(READLINE_TARGET) $(CUDA_TARGET) $(XDRFILE_TARGET) $(ARPACK_TARGET) + $(CXX) -o cpptraj$(SFX)$(EXE) $(OBJECTS) $(CUDA_TARGET) $(FFT_TARGET) $(READLINE_LIB) $(CPPTRAJ_LIB) $(LDFLAGS) # AmbPDB ------------------------------- install_ambpdb: ambpdb$(EXE) @@ -34,12 +34,12 @@ ambpdb$(EXE): $(AMBPDB_OBJECTS) $(XDRFILE_TARGET) # libcpptraj --------------------------- # Rule to make libcpptraj-specific objects %.LIBCPPTRAJ.o : %.cpp - $(CXX) -c -o $@ $(CXXFLAGS) -DLIBCPPTRAJ $(DBGFLAGS) $< + $(CXX) $(DIRECTIVES) -DLIBCPPTRAJ $(INCLUDE) $(CXXFLAGS) -c -o $@ $< libcpptraj: $(LIBCPPTRAJ_TARGET) -$(CPPTRAJLIB)/libcpptraj$(SHARED_SUFFIX): $(LIBCPPTRAJ_OBJECTS) $(FFT_DEPEND) $(XDRFILE_TARGET) - $(CXX) -shared -o $(CPPTRAJLIB)/libcpptraj$(SHARED_SUFFIX) $(LIBCPPTRAJ_OBJECTS) $(FFT_LIB) $(CPPTRAJ_LIB) $(LDFLAGS) +$(CPPTRAJLIB)/libcpptraj$(SHARED_SUFFIX): $(LIBCPPTRAJ_OBJECTS) $(FFT_TARGET) $(XDRFILE_TARGET) $(ARPACK_TARGET) + $(CXX) -shared -o $(CPPTRAJLIB)/libcpptraj$(SHARED_SUFFIX) $(LIBCPPTRAJ_OBJECTS) $(FFT_TARGET) $(CPPTRAJ_LIB) $(LDFLAGS) nolibcpptraj: @echo "" @@ -51,12 +51,18 @@ nolibcpptraj: nproc: cd ../util && $(MAKE) -# Additional library targets +# Internal object/library targets +pub_fft.o: pub_fft.F90 + $(FC) $(FPPFLAGS) -c $(FFLAGS) -o $@ pub_fft.F90 + readline/libreadline.a: readline/Makefile - cd $(READLINE_HOME) && $(MAKE) all + cd readline && $(MAKE) all xdrfile/libxdrfile.a: xdrfile/Makefile - cd $(XDRFILE_HOME) && $(MAKE) all + cd xdrfile && $(MAKE) all + +arpack/libarpack.a: arpack/Makefile + cd arpack && $(MAKE) install noreadline: @echo "" @@ -68,16 +74,14 @@ noxdrfile: @echo "Skipping bundled XDRFILE build" @echo "" +noarpack: + @echo "" + @echo "Skipping bundled ARPACK build" + @echo "" + cuda_kernels/libcpptraj_cuda.a: $(CUDA_SOURCES) cd cuda_kernels && $(MAKE) all -# Individual file targets -$(FFT_DEPEND): pub_fft.F90 - $(FC) $(FPPFLAGS) -c $(FFLAGS) -o $@ pub_fft.F90 - -ReadLine.o: ReadLine.cpp - $(CXX) $(CXXFLAGS) -I$(READLINE_HOME) -c -o $@ ReadLine.cpp - # Dependency targets findDepend: FindDepend.o $(CXX) -o findDepend FindDepend.o @@ -90,9 +94,10 @@ dependclean: # Clean/uninstall targets clean: - /bin/rm -f $(OBJECTS) $(FFT_DEPEND) cpptraj$(SFX) AmbPDB.o ambpdb *.LIBCPPTRAJ.o libcpptraj$(SHARED_SUFFIX) + /bin/rm -f $(OBJECTS) $(FFT_TARGET) cpptraj$(SFX) AmbPDB.o ambpdb *.LIBCPPTRAJ.o libcpptraj$(SHARED_SUFFIX) cd readline && $(MAKE) clean cd xdrfile && $(MAKE) clean + cd arpack && $(MAKE) clean cd cuda_kernels && $(MAKE) clean uninstall: diff --git a/src/Matrix_3x3.cpp b/src/Matrix_3x3.cpp index 4d3e971765..d0da58d582 100644 --- a/src/Matrix_3x3.cpp +++ b/src/Matrix_3x3.cpp @@ -86,9 +86,9 @@ void Matrix_3x3::Zero() { void Matrix_3x3::Print(const char* Title) const { mprintf(" %s\n",Title); - mprintf(" %8.4f %8.4f %8.4f\n", M_[0], M_[1], M_[2]); - mprintf(" %8.4f %8.4f %8.4f\n", M_[3], M_[4], M_[5]); - mprintf(" %8.4f %8.4f %8.4f\n", M_[6], M_[7], M_[8]); + mprintf(" %16.10f %16.10f %16.10f\n", M_[0], M_[1], M_[2]); + mprintf(" %16.10f %16.10f %16.10f\n", M_[3], M_[4], M_[5]); + mprintf(" %16.10f %16.10f %16.10f\n", M_[6], M_[7], M_[8]); } // ----------------------------------------------------------------------------- diff --git a/src/PairList.cpp b/src/PairList.cpp index 87938d18d9..ba8c7eba2d 100644 --- a/src/PairList.cpp +++ b/src/PairList.cpp @@ -95,8 +95,10 @@ void PairList::GridAtom(int atomIdx, Vec3 const& frac, Vec3 const& cart) { int i2 = (int)((frac[1]) * (double)nGridY_); int i3 = (int)((frac[2]) * (double)nGridZ_); int idx = (i3*nGridX_*nGridY_)+(i2*nGridX_)+i1; - //mprintf("GRID2 atom assigned to cell %6i%6i%10.5f%10.5f%10.5f\n", - // atomIdx+1, idx+1, frac[0], frac[1], frac[2]); +# ifdef DEBUG_PAIRLIST + mprintf("GRID2 atom assigned to cell %6i%6i%10.5f%10.5f%10.5f\n", + atomIdx+1, idx+1, frac[0], frac[1], frac[2]); +# endif if (idx < 0 || idx >= (int)cells_.size()) { // Sanity check mprinterr("Internal Error: Grid %i is out of range (>= %zu || < 0)\n", idx, cells_.size()); @@ -125,6 +127,10 @@ void PairList::GridUnitCell(Frame const& frmIn, Matrix_3x3 const& ucell, Vec3 fc( XYZ[0]*recip[0], XYZ[1]*recip[4], XYZ[2]*recip[8] ); Vec3 fcw(fc[0]-floor(fc[0]), fc[1]-floor(fc[1]), fc[2]-floor(fc[2])); Vec3 ccw(fcw[0]*ucell[0], fcw[1]*ucell[4], fcw[2]*ucell[8] ); +# ifdef DEBUG_PAIRLIST + mprintf("DBG: o %6i fc=%7.3f%7.3f%7.3f fcw=%7.3f%7.3f%7.3f ccw=%7.3f%7.3f%7.3f\n", + *atom+1, fc[0], fc[1], fc[2], fcw[0], fcw[1], fcw[2], ccw[0], ccw[1], ccw[2]); +# endif GridAtom( atom-maskIn.begin(), fcw, ccw ); } } else { @@ -134,6 +140,10 @@ void PairList::GridUnitCell(Frame const& frmIn, Matrix_3x3 const& ucell, Vec3 fc = recip * Vec3(frmIn.XYZ(*atom)); Vec3 fcw(fc[0]-floor(fc[0]), fc[1]-floor(fc[1]), fc[2]-floor(fc[2])); Vec3 ccw = ucell.TransposeMult( fcw ); +# ifdef DEBUG_PAIRLIST + mprintf("DBG: n %6i fc=%7.3f%7.3f%7.3f fcw=%7.3f%7.3f%7.3f ccw=%7.3f%7.3f%7.3f\n", + *atom+1, fc[0], fc[1], fc[2], fcw[0], fcw[1], fcw[2], ccw[0], ccw[1], ccw[2]); +# endif GridAtom( atom-maskIn.begin(), fcw, ccw ); } } diff --git a/src/PairList.h b/src/PairList.h index 48968f96ed..82e9f4699f 100644 --- a/src/PairList.h +++ b/src/PairList.h @@ -42,6 +42,11 @@ class PairList { Vec3 const& TransVec(int t) const { return translateVec_[t]; } /// \return Array containing wrapped fractional coords. Varray const& FracCoords() const { return Frac_; } +# ifdef DEBUG_PAIRLIST + int NX() const { return nGridX_; } + int NY() const { return nGridY_; } + int NZ() const { return nGridZ_; } +# endif private: /// Determine neighbors and translation vectors for each cell. void CalcGridPointers(int,int); diff --git a/src/RPNcalc.cpp b/src/RPNcalc.cpp index a6ccdac704..ac4761c461 100644 --- a/src/RPNcalc.cpp +++ b/src/RPNcalc.cpp @@ -235,8 +235,9 @@ int RPNcalc::ProcessExpression(std::string const& expression) { bool has_colon = false; // For index enum BracketState { NONE, OPEN, CLOSED }; BracketState bracket = NONE; - while (ptr != expression.end() && !isOpChar(*ptr) && !isspace(*ptr,loc)) + while (ptr != expression.end() && !isspace(*ptr,loc)) { + if (bracket != OPEN && isOpChar(*ptr)) break; //mprintf("DEBUG: Var '%c'\n", *ptr); varname.push_back( *(ptr++) ); // Check for brackets (Aspect) diff --git a/src/Version.h b/src/Version.h index 0cacbf2782..39fd913663 100644 --- a/src/Version.h +++ b/src/Version.h @@ -4,5 +4,5 @@ #define CPPTRAJ_VERSION_STRLEN 7 #endif #ifndef CPPTRAJ_INTERNAL_VERSION -#define CPPTRAJ_INTERNAL_VERSION "V4.3.4" +#define CPPTRAJ_INTERNAL_VERSION "V4.3.5" #endif diff --git a/src/arpack/LICENSE b/src/arpack/LICENSE new file mode 100644 index 0000000000..155dafbd8d --- /dev/null +++ b/src/arpack/LICENSE @@ -0,0 +1,35 @@ +BSD Software License + +Pertains to ARPACK and P_ARPACK + +Copyright (c) 1996-2008 Rice University. +Developed by D.C. Sorensen, R.B. Lehoucq, C. Yang, and K. Maschhoff. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer listed + in this license in the documentation and/or other materials + provided with the distribution. + +- Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/arpack/Makefile b/src/arpack/Makefile new file mode 100644 index 0000000000..0e052e9b8f --- /dev/null +++ b/src/arpack/Makefile @@ -0,0 +1,33 @@ +include ../../config.h +LIBDIR = . + +AR = ar rv +RANLIB = ranlib + +.f.o: + $(FC) -c $(F77FLAGS) -o $@ $< + +install: $(LIBDIR)/libarpack.a + +ARPACKLIB= ivout.o dvout.o dgetv0.o dlaqrb.o dnaitr.o dnapps.o \ +dnaup2.o dnaupd.o dnconv.o dneigh.o dmout.o \ +dneupd.o dngets.o dsaitr.o dsapps.o dsaup2.o \ +dsaupd.o dsconv.o dseigt.o dsesrt.o dseupd.o \ +dsgets.o dsortc.o dsortr.o dstatn.o dstats.o dstqrb.o arsecond.o + +SARPACKLIB= svout.o sgetv0.o slaqrb.o snaitr.o snapps.o \ +snaup2.o snaupd.o snconv.o sneigh.o smout.o \ +sneupd.o sngets.o ssaitr.o ssapps.o ssaup2.o \ +ssaupd.o ssconv.o sseigt.o ssesrt.o sseupd.o \ +ssgets.o ssortc.o ssortr.o sstatn.o sstats.o sstqrb.o + +$(LIBDIR)/libarpack.a: $(ARPACKLIB) + $(AR) libarpack.a $(ARPACKLIB) + $(RANLIB) libarpack.a + +clean: + -/bin/rm -f *.o _*.f *__genmod.* libarpack.a + +uninstall: + -rm -f $(LIBDIR)/libarpack.a + diff --git a/src/arpack/README b/src/arpack/README new file mode 100644 index 0000000000..5c776c1ffe --- /dev/null +++ b/src/arpack/README @@ -0,0 +1,114 @@ +NOTE: This is a pared-down version of ARPACK for cpptraj that only includes + the double-precision routines. + +1. You have successfully unbundled ARPACK and are now in the ARPACK + directory that was created for you. + +2. Recent bug fixes are included in patch.tar.gz and ppatch.tar.gz + (only needed if you are using PARPACK also.) If you have not + retrieved these files, please do so and place them in the + directory right above the current directory. (They should + be in the same directory where arpack96.tar reside). + Use uncompress or gunzip to unzip the tar files, and use 'tar -xvf ' + to unbundle these patches. The source codes in these patches will + overwrite those contained in arpack96.tar and parpack96.tar. + +3. Upon executing the 'ls | more ' command you should see + + BLAS + DOCUMENTS + EXAMPLES + LAPACK + README + SRC + UTIL + Makefile + ARmake.inc + ARMAKES + + The following entries are directories: + + ARMAKES, BLAS, DOCUMENTS, EXAMPLES, LAPACK, SRC, UTIL + + The directory SRC contains the top level routines including + the highest level reverse communication interface routines + + ssaupd, dsaupd - symmetric single and double precision + snaupd, dnaupd - non-symmetric single and double precision + cnaupd, cnaupd - complex non-symmetric single and double precision + + The headers of these routines contain full documentation of calling + sequence and usage. Additional information is in the DOCUMENTS directory. + + +4. Example driver programs that illustrate all the computational modes, + data types and precisions may be found in the EXAMPLES directory. + Upon executing the 'ls EXAMPLES | more ' command you should see + + BAND + COMPLEX + NONSYM + README + SIMPLE + SVD + SYM + + Example programs for banded, complex, nonsymmetric, symmetric, + and singular value decomposition may be found in the directories + BAND, COMPLEX, NONSYM, SYM, SVD respectively. Look at the README + file for further information. To get started, get into the SIMPLE + directory to see example programs that illustrate the use of ARPACK in + the simplest modes of operation for the most commonly posed + standard eigenvalue problems. + + The following instructions explain how to make the ARPACK library. + + +5. Before you can compile anything, you must first edit and correct the file + ARmake.inc. Sample ARmake.inc's can be found in the ARMAKES directory. + Edit "ARmake.inc" and change the definition "home" to the root of the + source tree (Top level of ARPACK directory) + + The makefile is set up to build a self-contained library which includes + the needed BLAS 1/2/3 and LAPACK routines. If you already have the + BLAS and LAPACK libraries installed on your system you might want to + change the definition of DIRS as indicated in the ARmake.inc file. + + *** NOTE *** Unless the LAPACK library on your system is version 2.0, + we strongly recommend that you install the LAPACK routines provided with + ARPACK. Note that the current LAPACK release is version 3.0; if you are + not sure which version of LAPACK is installed, pleaase compile and link + to the subset of LAPACK included with ARPACK. + + +6. You will also need to change the file "second.f" in the UTIL directory + to whatever is appropriate for timing on your system. The "second" routine + provided works on most workstations. If you are running on a Cray, + you can just edit the makefile in UTIL and take out the reference to + "second.o" to use the system second routine. + + +7. Do "make lib" in the current directory to build the standard library + "libarpack_$(PLAT).a" + +8. Within DOCUMENTS directory there are three files + + ex-sym.doc + ex-nonsym.doc and + ex-complex.doc + + for templates on how to invoke the computational modes of ARPACK. + Also look in the README file for explanations concerning the + other documents. + + + Danny Sorensen at sorensen@caam.rice.edu + Richard Lehoucq at rblehou@sandia.gov + Chao Yang at cyang@lbl.gov + Kristi Maschhoff at kristyn@tera.com + +If you have questions regarding using ARPACK, please send email +to arpack@caam.rice.edu. + + Good luck and enjoy. + diff --git a/src/arpack/arsecond.f b/src/arpack/arsecond.f new file mode 100644 index 0000000000..21f914cdfc --- /dev/null +++ b/src/arpack/arsecond.f @@ -0,0 +1,36 @@ + SUBROUTINE ARSECOND( T ) +* + REAL T +* +* -- LAPACK auxiliary routine (preliminary version) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* July 26, 1991 +* +* Purpose +* ======= +* +* ARSECOND returns the user time for a process in seconds. +* This version gets the time from the system function ETIME. +* +* .. Local Scalars .. + REAL T1 +* .. +* .. Local Arrays .. + REAL TARRAY( 2 ) +* .. +* .. External Functions .. + REAL ETIME +* EXTERNAL ETIME +* .. +* .. Executable Statements .. +* + + T1 = ETIME( TARRAY ) + T = TARRAY( 1 ) + + RETURN +* +* End of ARSECOND +* + END diff --git a/src/arpack/debug.h b/src/arpack/debug.h new file mode 100644 index 0000000000..5eb0bb1b3d --- /dev/null +++ b/src/arpack/debug.h @@ -0,0 +1,16 @@ +c +c\SCCS Information: @(#) +c FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 +c +c %---------------------------------% +c | See debug.doc for documentation | +c %---------------------------------% + integer logfil, ndigit, mgetv0, + & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, + & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, + & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd + common /debug/ + & logfil, ndigit, mgetv0, + & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, + & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, + & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd diff --git a/src/arpack/dgetv0.f b/src/arpack/dgetv0.f new file mode 100644 index 0000000000..c3036dd5af --- /dev/null +++ b/src/arpack/dgetv0.f @@ -0,0 +1,419 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dgetv0 +c +c\Description: +c Generate a random initial residual vector for the Arnoldi process. +c Force the residual vector to be in the range of the operator OP. +c +c\Usage: +c call dgetv0 +c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, +c IPNTR, WORKD, IERR ) +c +c\Arguments +c IDO Integer. (INPUT/OUTPUT) +c Reverse communication flag. IDO must be zero on the first +c call to dgetv0. +c ------------------------------------------------------------- +c IDO = 0: first call to the reverse communication interface +c IDO = -1: compute Y = OP * X where +c IPNTR(1) is the pointer into WORKD for X, +c IPNTR(2) is the pointer into WORKD for Y. +c This is for the initialization phase to force the +c starting vector into the range of OP. +c IDO = 2: compute Y = B * X where +c IPNTR(1) is the pointer into WORKD for X, +c IPNTR(2) is the pointer into WORKD for Y. +c IDO = 99: done +c ------------------------------------------------------------- +c +c BMAT Character*1. (INPUT) +c BMAT specifies the type of the matrix B in the (generalized) +c eigenvalue problem A*x = lambda*B*x. +c B = 'I' -> standard eigenvalue problem A*x = lambda*x +c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +c +c ITRY Integer. (INPUT) +c ITRY counts the number of times that dgetv0 is called. +c It should be set to 1 on the initial call to dgetv0. +c +c INITV Logical variable. (INPUT) +c .TRUE. => the initial residual vector is given in RESID. +c .FALSE. => generate a random initial residual vector. +c +c N Integer. (INPUT) +c Dimension of the problem. +c +c J Integer. (INPUT) +c Index of the residual vector to be generated, with respect to +c the Arnoldi process. J > 1 in case of a "restart". +c +c V Double precision N by J array. (INPUT) +c The first J-1 columns of V contain the current Arnoldi basis +c if this is a "restart". +c +c LDV Integer. (INPUT) +c Leading dimension of V exactly as declared in the calling +c program. +c +c RESID Double precision array of length N. (INPUT/OUTPUT) +c Initial residual vector to be generated. If RESID is +c provided, force RESID into the range of the operator OP. +c +c RNORM Double precision scalar. (OUTPUT) +c B-norm of the generated residual. +c +c IPNTR Integer array of length 3. (OUTPUT) +c +c WORKD Double precision work array of length 2*N. (REVERSE COMMUNICATION). +c On exit, WORK(1:N) = B*RESID to be used in SSAITR. +c +c IERR Integer. (OUTPUT) +c = 0: Normal exit. +c = -1: Cannot generate a nontrivial restarted residual vector +c in the range of the operator OP. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +c Restarted Arnoldi Iteration", Rice University Technical Report +c TR95-13, Department of Computational and Applied Mathematics. +c +c\Routines called: +c second ARPACK utility routine for timing. +c dvout ARPACK utility routine for vector output. +c dlarnv LAPACK routine for generating a random vector. +c dgemv Level 2 BLAS routine for matrix vector multiplication. +c dcopy Level 1 BLAS that copies one vector to another. +c ddot Level 1 BLAS that computes the scalar product of two vectors. +c dnrm2 Level 1 BLAS that computes the norm of a vector. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\SCCS Information: @(#) +c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2 +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dgetv0 + & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, + & ipntr, workd, ierr ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character bmat*1 + logical initv + integer ido, ierr, itry, j, ldv, n + Double precision + & rnorm +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + integer ipntr(3) + Double precision + & resid(n), v(ldv,j), workd(2*n) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %------------------------% +c | Local Scalars & Arrays | +c %------------------------% +c + logical first, inits, orth + integer idist, iseed(4), iter, msglvl, jj + Double precision + & rnorm0 + save first, iseed, inits, iter, msglvl, orth, rnorm0 +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dlarnv, dvout, dcopy, dgemv, second +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & ddot, dnrm2 + external ddot, dnrm2 +c +c %---------------------% +c | Intrinsic Functions | +c %---------------------% +c + intrinsic abs, sqrt +c +c %-----------------% +c | Data Statements | +c %-----------------% +c + data inits /.true./ +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c +c +c %-----------------------------------% +c | Initialize the seed of the LAPACK | +c | random number generator | +c %-----------------------------------% +c + if (inits) then + iseed(1) = 1 + iseed(2) = 3 + iseed(3) = 5 + iseed(4) = 7 + inits = .false. + end if +c + if (ido .eq. 0) then +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = mgetv0 +c + ierr = 0 + iter = 0 + first = .FALSE. + orth = .FALSE. +c +c %-----------------------------------------------------% +c | Possibly generate a random starting vector in RESID | +c | Use a LAPACK random number generator used by the | +c | matrix generation routines. | +c | idist = 1: uniform (0,1) distribution; | +c | idist = 2: uniform (-1,1) distribution; | +c | idist = 3: normal (0,1) distribution; | +c %-----------------------------------------------------% +c + if (.not.initv) then + idist = 2 + call dlarnv (idist, iseed, n, resid) + end if +c +c %----------------------------------------------------------% +c | Force the starting vector into the range of OP to handle | +c | the generalized problem when B is possibly (singular). | +c %----------------------------------------------------------% +c + call arsecond (t2) + if (bmat .eq. 'G') then + nopx = nopx + 1 + ipntr(1) = 1 + ipntr(2) = n + 1 + call dcopy (n, resid, 1, workd, 1) + ido = -1 + go to 9000 + end if + end if +c +c %-----------------------------------------% +c | Back from computing OP*(initial-vector) | +c %-----------------------------------------% +c + if (first) go to 20 +c +c %-----------------------------------------------% +c | Back from computing B*(orthogonalized-vector) | +c %-----------------------------------------------% +c + if (orth) go to 40 +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvopx = tmvopx + (t3 - t2) + end if +c +c %------------------------------------------------------% +c | Starting vector is now in the range of OP; r = OP*r; | +c | Compute B-norm of starting vector. | +c %------------------------------------------------------% +c + call arsecond (t2) + first = .TRUE. + if (bmat .eq. 'G') then + nbx = nbx + 1 + call dcopy (n, workd(n+1), 1, resid, 1) + ipntr(1) = n + 1 + ipntr(2) = 1 + ido = 2 + go to 9000 + else if (bmat .eq. 'I') then + call dcopy (n, resid, 1, workd, 1) + end if +c + 20 continue +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c + first = .FALSE. + if (bmat .eq. 'G') then + rnorm0 = ddot (n, resid, 1, workd, 1) + rnorm0 = sqrt(abs(rnorm0)) + else if (bmat .eq. 'I') then + rnorm0 = dnrm2(n, resid, 1) + end if + rnorm = rnorm0 +c +c %---------------------------------------------% +c | Exit if this is the very first Arnoldi step | +c %---------------------------------------------% +c + if (j .eq. 1) go to 50 +c +c %---------------------------------------------------------------- +c | Otherwise need to B-orthogonalize the starting vector against | +c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | +c | This is the case where an invariant subspace is encountered | +c | in the middle of the Arnoldi factorization. | +c | | +c | s = V^{T}*B*r; r = r - V*s; | +c | | +c | Stopping criteria used for iter. ref. is discussed in | +c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | +c %---------------------------------------------------------------% +c + orth = .TRUE. + 30 continue +c + call dgemv ('T', n, j-1, one, v, ldv, workd, 1, + & zero, workd(n+1), 1) + call dgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, + & one, resid, 1) +c +c %----------------------------------------------------------% +c | Compute the B-norm of the orthogonalized starting vector | +c %----------------------------------------------------------% +c + call arsecond (t2) + if (bmat .eq. 'G') then + nbx = nbx + 1 + call dcopy (n, resid, 1, workd(n+1), 1) + ipntr(1) = n + 1 + ipntr(2) = 1 + ido = 2 + go to 9000 + else if (bmat .eq. 'I') then + call dcopy (n, resid, 1, workd, 1) + end if +c + 40 continue +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c + if (bmat .eq. 'G') then + rnorm = ddot (n, resid, 1, workd, 1) + rnorm = sqrt(abs(rnorm)) + else if (bmat .eq. 'I') then + rnorm = dnrm2(n, resid, 1) + end if +c +c %--------------------------------------% +c | Check for further orthogonalization. | +c %--------------------------------------% +c + if (msglvl .gt. 2) then + call dvout (logfil, 1, [rnorm0], ndigit, + & '_getv0: re-orthonalization ; rnorm0 is') + call dvout (logfil, 1, [rnorm], ndigit, + & '_getv0: re-orthonalization ; rnorm is') + end if +c + if (rnorm .gt. 0.717*rnorm0) go to 50 +c + iter = iter + 1 + if (iter .le. 5) then +c +c %-----------------------------------% +c | Perform iterative refinement step | +c %-----------------------------------% +c + rnorm0 = rnorm + go to 30 + else +c +c %------------------------------------% +c | Iterative refinement step "failed" | +c %------------------------------------% +c + do 45 jj = 1, n + resid(jj) = zero + 45 continue + rnorm = zero + ierr = -1 + end if +c + 50 continue +c + if (msglvl .gt. 0) then + call dvout (logfil, 1, [rnorm], ndigit, + & '_getv0: B-norm of initial / restarted starting vector') + end if + if (msglvl .gt. 3) then + call dvout (logfil, n, resid, ndigit, + & '_getv0: initial / restarted starting vector') + end if + ido = 99 +c + call arsecond (t1) + tgetv0 = tgetv0 + (t1 - t0) +c + 9000 continue + return +c +c %---------------% +c | End of dgetv0 | +c %---------------% +c + end diff --git a/src/arpack/dlaqrb.f b/src/arpack/dlaqrb.f new file mode 100644 index 0000000000..d851b86361 --- /dev/null +++ b/src/arpack/dlaqrb.f @@ -0,0 +1,521 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dlaqrb +c +c\Description: +c Compute the eigenvalues and the Schur decomposition of an upper +c Hessenberg submatrix in rows and columns ILO to IHI. Only the +c last component of the Schur vectors are computed. +c +c This is mostly a modification of the LAPACK routine dlahqr. +c +c\Usage: +c call dlaqrb +c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO ) +c +c\Arguments +c WANTT Logical variable. (INPUT) +c = .TRUE. : the full Schur form T is required; +c = .FALSE.: only eigenvalues are required. +c +c N Integer. (INPUT) +c The order of the matrix H. N >= 0. +c +c ILO Integer. (INPUT) +c IHI Integer. (INPUT) +c It is assumed that H is already upper quasi-triangular in +c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless +c ILO = 1). SLAQRB works primarily with the Hessenberg +c submatrix in rows and columns ILO to IHI, but applies +c transformations to all of H if WANTT is .TRUE.. +c 1 <= ILO <= max(1,IHI); IHI <= N. +c +c H Double precision array, dimension (LDH,N). (INPUT/OUTPUT) +c On entry, the upper Hessenberg matrix H. +c On exit, if WANTT is .TRUE., H is upper quasi-triangular in +c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in +c standard form. If WANTT is .FALSE., the contents of H are +c unspecified on exit. +c +c LDH Integer. (INPUT) +c The leading dimension of the array H. LDH >= max(1,N). +c +c WR Double precision array, dimension (N). (OUTPUT) +c WI Double precision array, dimension (N). (OUTPUT) +c The real and imaginary parts, respectively, of the computed +c eigenvalues ILO to IHI are stored in the corresponding +c elements of WR and WI. If two eigenvalues are computed as a +c complex conjugate pair, they are stored in consecutive +c elements of WR and WI, say the i-th and (i+1)th, with +c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the +c eigenvalues are stored in the same order as on the diagonal +c of the Schur form returned in H, with WR(i) = H(i,i), and, if +c H(i:i+1,i:i+1) is a 2-by-2 diagonal block, +c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). +c +c Z Double precision array, dimension (N). (OUTPUT) +c On exit Z contains the last components of the Schur vectors. +c +c INFO Integer. (OUPUT) +c = 0: successful exit +c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI +c in a total of 30*(IHI-ILO+1) iterations; if INFO = i, +c elements i+1:ihi of WR and WI contain those eigenvalues +c which have been successfully computed. +c +c\Remarks +c 1. None. +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\Routines called: +c dlabad LAPACK routine that computes machine constants. +c dlamch LAPACK routine that determines machine constants. +c dlanhs LAPACK routine that computes various norms of a matrix. +c dlanv2 LAPACK routine that computes the Schur factorization of +c 2 by 2 nonsymmetric matrix in standard form. +c dlarfg LAPACK Householder reflection construction routine. +c dcopy Level 1 BLAS that copies one vector to another. +c drot Level 1 BLAS that applies a rotation to a 2 by 2 matrix. + +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/92: Version ' 2.4' +c Modified from the LAPACK routine dlahqr so that only the +c last component of the Schur vectors are computed. +c +c\SCCS Information: @(#) +c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2 +c +c\Remarks +c 1. None +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dlaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi, + & z, info ) +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + logical wantt + integer ihi, ilo, info, ldh, n +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & h( ldh, * ), wi( * ), wr( * ), z( * ) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & zero, one, dat1, dat2 + parameter (zero = 0.0D+0, one = 1.0D+0, dat1 = 7.5D-1, + & dat2 = -4.375D-1) +c +c %------------------------% +c | Local Scalars & Arrays | +c %------------------------% +c + integer i, i1, i2, itn, its, j, k, l, m, nh, nr + Double precision + & cs, h00, h10, h11, h12, h21, h22, h33, h33s, + & h43h34, h44, h44s, ovfl, s, smlnum, sn, sum, + & t1, t2, t3, tst1, ulp, unfl, v1, v2, v3 + Double precision + & v( 3 ), work( 1 ) +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dlamch, dlanhs + external dlamch, dlanhs +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dcopy, dlabad, dlanv2, dlarfg, drot +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + info = 0 +c +c %--------------------------% +c | Quick return if possible | +c %--------------------------% +c + if( n.eq.0 ) + & return + if( ilo.eq.ihi ) then + wr( ilo ) = h( ilo, ilo ) + wi( ilo ) = zero + return + end if +c +c %---------------------------------------------% +c | Initialize the vector of last components of | +c | the Schur vectors for accumulation. | +c %---------------------------------------------% +c + do 5 j = 1, n-1 + z(j) = zero + 5 continue + z(n) = one +c + nh = ihi - ilo + 1 +c +c %-------------------------------------------------------------% +c | Set machine-dependent constants for the stopping criterion. | +c | If norm(H) <= sqrt(OVFL), overflow should not occur. | +c %-------------------------------------------------------------% +c + unfl = dlamch( 'safe minimum' ) + ovfl = one / unfl + call dlabad( unfl, ovfl ) + ulp = dlamch( 'precision' ) + smlnum = unfl*( nh / ulp ) +c +c %---------------------------------------------------------------% +c | I1 and I2 are the indices of the first row and last column | +c | of H to which transformations must be applied. If eigenvalues | +c | only are computed, I1 and I2 are set inside the main loop. | +c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | +c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | +c %---------------------------------------------------------------% +c + if( wantt ) then + i1 = 1 + i2 = n + do 8 i=1,i2-2 + h(i1+i+1,i) = zero + 8 continue + else + do 9 i=1, ihi-ilo-1 + h(ilo+i+1,ilo+i-1) = zero + 9 continue + end if +c +c %---------------------------------------------------% +c | ITN is the total number of QR iterations allowed. | +c %---------------------------------------------------% +c + itn = 30*nh +c +c ------------------------------------------------------------------ +c The main loop begins here. I is the loop index and decreases from +c IHI to ILO in steps of 1 or 2. Each iteration of the loop works +c with the active submatrix in rows and columns L to I. +c Eigenvalues I+1 to IHI have already converged. Either L = ILO or +c H(L,L-1) is negligible so that the matrix splits. +c ------------------------------------------------------------------ +c + i = ihi + 10 continue + l = ilo + if( i.lt.ilo ) + & go to 150 + +c %--------------------------------------------------------------% +c | Perform QR iterations on rows and columns ILO to I until a | +c | submatrix of order 1 or 2 splits off at the bottom because a | +c | subdiagonal element has become negligible. | +c %--------------------------------------------------------------% + + do 130 its = 0, itn +c +c %----------------------------------------------% +c | Look for a single small subdiagonal element. | +c %----------------------------------------------% +c + do 20 k = i, l + 1, -1 + tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) ) + if( tst1.eq.zero ) + & tst1 = dlanhs( '1', i-l+1, h( l, l ), ldh, work ) + if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) ) + & go to 30 + 20 continue + 30 continue + l = k + if( l.gt.ilo ) then +c +c %------------------------% +c | H(L,L-1) is negligible | +c %------------------------% +c + h( l, l-1 ) = zero + end if +c +c %-------------------------------------------------------------% +c | Exit from loop if a submatrix of order 1 or 2 has split off | +c %-------------------------------------------------------------% +c + if( l.ge.i-1 ) + & go to 140 +c +c %---------------------------------------------------------% +c | Now the active submatrix is in rows and columns L to I. | +c | If eigenvalues only are being computed, only the active | +c | submatrix need be transformed. | +c %---------------------------------------------------------% +c + if( .not.wantt ) then + i1 = l + i2 = i + end if +c + if( its.eq.10 .or. its.eq.20 ) then +c +c %-------------------% +c | Exceptional shift | +c %-------------------% +c + s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) + h44 = dat1*s + h33 = h44 + h43h34 = dat2*s*s +c + else +c +c %-----------------------------------------% +c | Prepare to use Wilkinson's double shift | +c %-----------------------------------------% +c + h44 = h( i, i ) + h33 = h( i-1, i-1 ) + h43h34 = h( i, i-1 )*h( i-1, i ) + end if +c +c %-----------------------------------------------------% +c | Look for two consecutive small subdiagonal elements | +c %-----------------------------------------------------% +c + do 40 m = i - 2, l, -1 +c +c %---------------------------------------------------------% +c | Determine the effect of starting the double-shift QR | +c | iteration at row M, and see if this would make H(M,M-1) | +c | negligible. | +c %---------------------------------------------------------% +c + h11 = h( m, m ) + h22 = h( m+1, m+1 ) + h21 = h( m+1, m ) + h12 = h( m, m+1 ) + h44s = h44 - h11 + h33s = h33 - h11 + v1 = ( h33s*h44s-h43h34 ) / h21 + h12 + v2 = h22 - h11 - h33s - h44s + v3 = h( m+2, m+1 ) + s = abs( v1 ) + abs( v2 ) + abs( v3 ) + v1 = v1 / s + v2 = v2 / s + v3 = v3 / s + v( 1 ) = v1 + v( 2 ) = v2 + v( 3 ) = v3 + if( m.eq.l ) + & go to 50 + h00 = h( m-1, m-1 ) + h10 = h( m, m-1 ) + tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) ) + if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 ) + & go to 50 + 40 continue + 50 continue +c +c %----------------------% +c | Double-shift QR step | +c %----------------------% +c + do 120 k = m, i - 1 +c +c ------------------------------------------------------------ +c The first iteration of this loop determines a reflection G +c from the vector V and applies it from left and right to H, +c thus creating a nonzero bulge below the subdiagonal. +c +c Each subsequent iteration determines a reflection G to +c restore the Hessenberg form in the (K-1)th column, and thus +c chases the bulge one step toward the bottom of the active +c submatrix. NR is the order of G. +c ------------------------------------------------------------ +c + nr = min( 3, i-k+1 ) + if( k.gt.m ) + & call dcopy( nr, h( k, k-1 ), 1, v, 1 ) + call dlarfg( nr, v( 1 ), v( 2 ), 1, t1 ) + if( k.gt.m ) then + h( k, k-1 ) = v( 1 ) + h( k+1, k-1 ) = zero + if( k.lt.i-1 ) + & h( k+2, k-1 ) = zero + else if( m.gt.l ) then + h( k, k-1 ) = -h( k, k-1 ) + end if + v2 = v( 2 ) + t2 = t1*v2 + if( nr.eq.3 ) then + v3 = v( 3 ) + t3 = t1*v3 +c +c %------------------------------------------------% +c | Apply G from the left to transform the rows of | +c | the matrix in columns K to I2. | +c %------------------------------------------------% +c + do 60 j = k, i2 + sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j ) + h( k, j ) = h( k, j ) - sum*t1 + h( k+1, j ) = h( k+1, j ) - sum*t2 + h( k+2, j ) = h( k+2, j ) - sum*t3 + 60 continue +c +c %----------------------------------------------------% +c | Apply G from the right to transform the columns of | +c | the matrix in rows I1 to min(K+3,I). | +c %----------------------------------------------------% +c + do 70 j = i1, min( k+3, i ) + sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 ) + h( j, k ) = h( j, k ) - sum*t1 + h( j, k+1 ) = h( j, k+1 ) - sum*t2 + h( j, k+2 ) = h( j, k+2 ) - sum*t3 + 70 continue +c +c %----------------------------------% +c | Accumulate transformations for Z | +c %----------------------------------% +c + sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 ) + z( k ) = z( k ) - sum*t1 + z( k+1 ) = z( k+1 ) - sum*t2 + z( k+2 ) = z( k+2 ) - sum*t3 + + else if( nr.eq.2 ) then +c +c %------------------------------------------------% +c | Apply G from the left to transform the rows of | +c | the matrix in columns K to I2. | +c %------------------------------------------------% +c + do 90 j = k, i2 + sum = h( k, j ) + v2*h( k+1, j ) + h( k, j ) = h( k, j ) - sum*t1 + h( k+1, j ) = h( k+1, j ) - sum*t2 + 90 continue +c +c %----------------------------------------------------% +c | Apply G from the right to transform the columns of | +c | the matrix in rows I1 to min(K+3,I). | +c %----------------------------------------------------% +c + do 100 j = i1, i + sum = h( j, k ) + v2*h( j, k+1 ) + h( j, k ) = h( j, k ) - sum*t1 + h( j, k+1 ) = h( j, k+1 ) - sum*t2 + 100 continue +c +c %----------------------------------% +c | Accumulate transformations for Z | +c %----------------------------------% +c + sum = z( k ) + v2*z( k+1 ) + z( k ) = z( k ) - sum*t1 + z( k+1 ) = z( k+1 ) - sum*t2 + end if + 120 continue + + 130 continue +c +c %-------------------------------------------------------% +c | Failure to converge in remaining number of iterations | +c %-------------------------------------------------------% +c + info = i + return + + 140 continue + + if( l.eq.i ) then +c +c %------------------------------------------------------% +c | H(I,I-1) is negligible: one eigenvalue has converged | +c %------------------------------------------------------% +c + wr( i ) = h( i, i ) + wi( i ) = zero + + else if( l.eq.i-1 ) then +c +c %--------------------------------------------------------% +c | H(I-1,I-2) is negligible; | +c | a pair of eigenvalues have converged. | +c | | +c | Transform the 2-by-2 submatrix to standard Schur form, | +c | and compute and store the eigenvalues. | +c %--------------------------------------------------------% +c + call dlanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ), + & h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ), + & cs, sn ) + + if( wantt ) then +c +c %-----------------------------------------------------% +c | Apply the transformation to the rest of H and to Z, | +c | as required. | +c %-----------------------------------------------------% +c + if( i2.gt.i ) + & call drot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh, + & cs, sn ) + call drot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) + sum = cs*z( i-1 ) + sn*z( i ) + z( i ) = cs*z( i ) - sn*z( i-1 ) + z( i-1 ) = sum + end if + end if +c +c %---------------------------------------------------------% +c | Decrement number of remaining iterations, and return to | +c | start of the main loop with new value of I. | +c %---------------------------------------------------------% +c + itn = itn - its + i = l - 1 + go to 10 + + 150 continue + return +c +c %---------------% +c | End of dlaqrb | +c %---------------% +c + end diff --git a/src/arpack/dmout.f b/src/arpack/dmout.f new file mode 100644 index 0000000000..72edc042fa --- /dev/null +++ b/src/arpack/dmout.f @@ -0,0 +1,167 @@ +*----------------------------------------------------------------------- +* Routine: DMOUT +* +* Purpose: Real matrix output routine. +* +* Usage: CALL DMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) +* +* Arguments +* M - Number of rows of A. (Input) +* N - Number of columns of A. (Input) +* A - Real M by N matrix to be printed. (Input) +* LDA - Leading dimension of A exactly as specified in the +* dimension statement of the calling program. (Input) +* IFMT - Format to be used in printing matrix A. (Input) +* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +* If IDIGIT .LT. 0, printing is done with 72 columns. +* If IDIGIT .GT. 0, printing is done with 132 columns. +* +*----------------------------------------------------------------------- +* + SUBROUTINE DMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) +* ... +* ... SPECIFICATIONS FOR ARGUMENTS +* ... +* ... SPECIFICATIONS FOR LOCAL VARIABLES +* .. Scalar Arguments .. + CHARACTER*( * ) IFMT + INTEGER IDIGIT, LDA, LOUT, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* .. Local Scalars .. + CHARACTER*80 LINE + INTEGER I, J, K1, K2, LLL, NDIGIT +* .. +* .. Local Arrays .. + CHARACTER ICOL( 3 ) +* .. +* .. Intrinsic Functions .. + INTRINSIC LEN, MIN, MIN0 +* .. +* .. Data statements .. + DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', + $ 'l' / +* .. +* .. Executable Statements .. +* ... +* ... FIRST EXECUTABLE STATEMENT +* + LLL = MIN( LEN( IFMT ), 80 ) + DO 10 I = 1, LLL + LINE( I: I ) = '-' + 10 CONTINUE +* + DO 20 I = LLL + 1, 80 + LINE( I: I ) = ' ' + 20 CONTINUE +* + WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) + 9999 FORMAT( / 1X, A, / 1X, A ) +* + IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) + $ RETURN + NDIGIT = IDIGIT + IF( IDIGIT.EQ.0 ) + $ NDIGIT = 4 +* +*======================================================================= +* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +*======================================================================= +* + IF( IDIGIT.LT.0 ) THEN + NDIGIT = -IDIGIT + IF( NDIGIT.LE.4 ) THEN + DO 40 K1 = 1, N, 5 + K2 = MIN0( N, K1+4 ) + WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) + DO 30 I = 1, M + WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) + 30 CONTINUE + 40 CONTINUE +* + ELSE IF( NDIGIT.LE.6 ) THEN + DO 60 K1 = 1, N, 4 + K2 = MIN0( N, K1+3 ) + WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) + DO 50 I = 1, M + WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) + 50 CONTINUE + 60 CONTINUE +* + ELSE IF( NDIGIT.LE.10 ) THEN + DO 80 K1 = 1, N, 3 + K2 = MIN0( N, K1+2 ) + WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) + DO 70 I = 1, M + WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) + 70 CONTINUE + 80 CONTINUE +* + ELSE + DO 100 K1 = 1, N, 2 + K2 = MIN0( N, K1+1 ) + WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) + DO 90 I = 1, M + WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) + 90 CONTINUE + 100 CONTINUE + END IF +* +*======================================================================= +* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +*======================================================================= +* + ELSE + IF( NDIGIT.LE.4 ) THEN + DO 120 K1 = 1, N, 10 + K2 = MIN0( N, K1+9 ) + WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) + DO 110 I = 1, M + WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) + 110 CONTINUE + 120 CONTINUE +* + ELSE IF( NDIGIT.LE.6 ) THEN + DO 140 K1 = 1, N, 8 + K2 = MIN0( N, K1+7 ) + WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) + DO 130 I = 1, M + WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) + 130 CONTINUE + 140 CONTINUE +* + ELSE IF( NDIGIT.LE.10 ) THEN + DO 160 K1 = 1, N, 6 + K2 = MIN0( N, K1+5 ) + WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) + DO 150 I = 1, M + WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) + 150 CONTINUE + 160 CONTINUE +* + ELSE + DO 180 K1 = 1, N, 5 + K2 = MIN0( N, K1+4 ) + WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) + DO 170 I = 1, M + WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) + 170 CONTINUE + 180 CONTINUE + END IF + END IF + WRITE( LOUT, FMT = 9990 ) +* + 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) ) + 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) ) + 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) ) + 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) ) + 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 10D12.3 ) + 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 8D14.5 ) + 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 6D18.9 ) + 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 5D22.13 ) + 9990 FORMAT( 1X, ' ' ) +* + RETURN + END diff --git a/src/arpack/dnaitr.f b/src/arpack/dnaitr.f new file mode 100644 index 0000000000..737f4d9db1 --- /dev/null +++ b/src/arpack/dnaitr.f @@ -0,0 +1,840 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dnaitr +c +c\Description: +c Reverse communication interface for applying NP additional steps to +c a K step nonsymmetric Arnoldi factorization. +c +c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T +c +c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. +c +c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T +c +c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. +c +c where OP and B are as in dnaupd. The B-norm of r_{k+p} is also +c computed and returned. +c +c\Usage: +c call dnaitr +c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, +c IPNTR, WORKD, INFO ) +c +c\Arguments +c IDO Integer. (INPUT/OUTPUT) +c Reverse communication flag. +c ------------------------------------------------------------- +c IDO = 0: first call to the reverse communication interface +c IDO = -1: compute Y = OP * X where +c IPNTR(1) is the pointer into WORK for X, +c IPNTR(2) is the pointer into WORK for Y. +c This is for the restart phase to force the new +c starting vector into the range of OP. +c IDO = 1: compute Y = OP * X where +c IPNTR(1) is the pointer into WORK for X, +c IPNTR(2) is the pointer into WORK for Y, +c IPNTR(3) is the pointer into WORK for B * X. +c IDO = 2: compute Y = B * X where +c IPNTR(1) is the pointer into WORK for X, +c IPNTR(2) is the pointer into WORK for Y. +c IDO = 99: done +c ------------------------------------------------------------- +c When the routine is used in the "shift-and-invert" mode, the +c vector B * Q is already available and do not need to be +c recompute in forming OP * Q. +c +c BMAT Character*1. (INPUT) +c BMAT specifies the type of the matrix B that defines the +c semi-inner product for the operator OP. See dnaupd. +c B = 'I' -> standard eigenvalue problem A*x = lambda*x +c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x +c +c N Integer. (INPUT) +c Dimension of the eigenproblem. +c +c K Integer. (INPUT) +c Current size of V and H. +c +c NP Integer. (INPUT) +c Number of additional Arnoldi steps to take. +c +c NB Integer. (INPUT) +c Blocksize to be used in the recurrence. +c Only work for NB = 1 right now. The goal is to have a +c program that implement both the block and non-block method. +c +c RESID Double precision array of length N. (INPUT/OUTPUT) +c On INPUT: RESID contains the residual vector r_{k}. +c On OUTPUT: RESID contains the residual vector r_{k+p}. +c +c RNORM Double precision scalar. (INPUT/OUTPUT) +c B-norm of the starting residual on input. +c B-norm of the updated residual r_{k+p} on output. +c +c V Double precision N by K+NP array. (INPUT/OUTPUT) +c On INPUT: V contains the Arnoldi vectors in the first K +c columns. +c On OUTPUT: V contains the new NP Arnoldi vectors in the next +c NP columns. The first K columns are unchanged. +c +c LDV Integer. (INPUT) +c Leading dimension of V exactly as declared in the calling +c program. +c +c H Double precision (K+NP) by (K+NP) array. (INPUT/OUTPUT) +c H is used to store the generated upper Hessenberg matrix. +c +c LDH Integer. (INPUT) +c Leading dimension of H exactly as declared in the calling +c program. +c +c IPNTR Integer array of length 3. (OUTPUT) +c Pointer to mark the starting locations in the WORK for +c vectors used by the Arnoldi iteration. +c ------------------------------------------------------------- +c IPNTR(1): pointer to the current operand vector X. +c IPNTR(2): pointer to the current result vector Y. +c IPNTR(3): pointer to the vector B * X when used in the +c shift-and-invert mode. X is the current operand. +c ------------------------------------------------------------- +c +c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +c Distributed array to be used in the basic Arnoldi iteration +c for reverse communication. The calling program should not +c use WORKD as temporary workspace during the iteration !!!!!! +c On input, WORKD(1:N) = B*RESID and is used to save some +c computation at the first step. +c +c INFO Integer. (OUTPUT) +c = 0: Normal exit. +c > 0: Size of the spanning invariant subspace of OP found. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +c Restarted Arnoldi Iteration", Rice University Technical Report +c TR95-13, Department of Computational and Applied Mathematics. +c +c\Routines called: +c dgetv0 ARPACK routine to generate the initial vector. +c ivout ARPACK utility routine that prints integers. +c second ARPACK utility routine for timing. +c dmout ARPACK utility routine that prints matrices +c dvout ARPACK utility routine that prints vectors. +c dlabad LAPACK routine that computes machine constants. +c dlamch LAPACK routine that determines machine constants. +c dlascl LAPACK routine for careful scaling of a matrix. +c dlanhs LAPACK routine that computes various norms of a matrix. +c dgemv Level 2 BLAS routine for matrix vector multiplication. +c daxpy Level 1 BLAS that computes a vector triad. +c dscal Level 1 BLAS that scales a vector. +c dcopy Level 1 BLAS that copies one vector to another . +c ddot Level 1 BLAS that computes the scalar product of two vectors. +c dnrm2 Level 1 BLAS that computes the norm of a vector. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/92: Version ' 2.4' +c +c\SCCS Information: @(#) +c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 +c +c\Remarks +c The algorithm implemented is: +c +c restart = .false. +c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; +c r_{k} contains the initial residual vector even for k = 0; +c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already +c computed by the calling program. +c +c betaj = rnorm ; p_{k+1} = B*r_{k} ; +c For j = k+1, ..., k+np Do +c 1) if ( betaj < tol ) stop or restart depending on j. +c ( At present tol is zero ) +c if ( restart ) generate a new starting vector. +c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; +c p_{j} = p_{j}/betaj +c 3) r_{j} = OP*v_{j} where OP is defined as in dnaupd +c For shift-invert mode p_{j} = B*v_{j} is already available. +c wnorm = || OP*v_{j} || +c 4) Compute the j-th step residual vector. +c w_{j} = V_{j}^T * B * OP * v_{j} +c r_{j} = OP*v_{j} - V_{j} * w_{j} +c H(:,j) = w_{j}; +c H(j,j-1) = rnorm +c rnorm = || r_(j) || +c If (rnorm > 0.717*wnorm) accept step and go back to 1) +c 5) Re-orthogonalization step: +c s = V_{j}'*B*r_{j} +c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || +c alphaj = alphaj + s_{j}; +c 6) Iterative refinement step: +c If (rnorm1 > 0.717*rnorm) then +c rnorm = rnorm1 +c accept step and go back to 1) +c Else +c rnorm = rnorm1 +c If this is the first time in step 6), go to 5) +c Else r_{j} lies in the span of V_{j} numerically. +c Set r_{j} = 0 and rnorm = 0; go to 1) +c EndIf +c End Do +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dnaitr + & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, + & ipntr, workd, info) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character bmat*1 + integer ido, info, k, ldh, ldv, n, nb, np + Double precision + & rnorm +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + integer ipntr(3) + Double precision + & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + logical first, orth1, orth2, rstart, step3, step4 + integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, + & jj + Double precision + & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl, + & wnorm + save first, orth1, orth2, rstart, step3, step4, + & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, + & betaj, rnorm1, smlnum, ulp, unfl, wnorm +c +c %-----------------------% +c | Local Array Arguments | +c %-----------------------% +c + Double precision + & xtemp(2) +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external daxpy, dcopy, dscal, dgemv, dgetv0, dlabad, + & dvout, dmout, ivout, second +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & ddot, dnrm2, dlanhs, dlamch + external ddot, dnrm2, dlanhs, dlamch +c +c %---------------------% +c | Intrinsic Functions | +c %---------------------% +c + intrinsic abs, sqrt +c +c %-----------------% +c | Data statements | +c %-----------------% +c + data first / .true. / +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + if (first) then +c +c %-----------------------------------------% +c | Set machine-dependent constants for the | +c | the splitting and deflation criterion. | +c | If norm(H) <= sqrt(OVFL), | +c | overflow should not occur. | +c | REFERENCE: LAPACK subroutine dlahqr | +c %-----------------------------------------% +c + unfl = dlamch( 'safe minimum' ) + ovfl = one / unfl + call dlabad( unfl, ovfl ) + ulp = dlamch( 'precision' ) + smlnum = unfl*( n / ulp ) + first = .false. + end if +c + if (ido .eq. 0) then +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = mnaitr +c +c %------------------------------% +c | Initial call to this routine | +c %------------------------------% +c + info = 0 + step3 = .false. + step4 = .false. + rstart = .false. + orth1 = .false. + orth2 = .false. + j = k + 1 + ipj = 1 + irj = ipj + n + ivj = irj + n + end if +c +c %-------------------------------------------------% +c | When in reverse communication mode one of: | +c | STEP3, STEP4, ORTH1, ORTH2, RSTART | +c | will be .true. when .... | +c | STEP3: return from computing OP*v_{j}. | +c | STEP4: return from computing B-norm of OP*v_{j} | +c | ORTH1: return from computing B-norm of r_{j+1} | +c | ORTH2: return from computing B-norm of | +c | correction to the residual vector. | +c | RSTART: return from OP computations needed by | +c | dgetv0. | +c %-------------------------------------------------% +c + if (step3) go to 50 + if (step4) go to 60 + if (orth1) go to 70 + if (orth2) go to 90 + if (rstart) go to 30 +c +c %-----------------------------% +c | Else this is the first step | +c %-----------------------------% +c +c %--------------------------------------------------------------% +c | | +c | A R N O L D I I T E R A T I O N L O O P | +c | | +c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | +c %--------------------------------------------------------------% + + 1000 continue +c + if (msglvl .gt. 1) then + call ivout (logfil, 1, [j], ndigit, + & '_naitr: generating Arnoldi vector number') + call dvout (logfil, 1, [rnorm], ndigit, + & '_naitr: B-norm of the current residual is') + end if +c +c %---------------------------------------------------% +c | STEP 1: Check if the B norm of j-th residual | +c | vector is zero. Equivalent to determing whether | +c | an exact j-step Arnoldi factorization is present. | +c %---------------------------------------------------% +c + betaj = rnorm + if (rnorm .gt. zero) go to 40 +c +c %---------------------------------------------------% +c | Invariant subspace found, generate a new starting | +c | vector which is orthogonal to the current Arnoldi | +c | basis and continue the iteration. | +c %---------------------------------------------------% +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [j], ndigit, + & '_naitr: ****** RESTART AT STEP ******') + end if +c +c %---------------------------------------------% +c | ITRY is the loop variable that controls the | +c | maximum amount of times that a restart is | +c | attempted. NRSTRT is used by stat.h | +c %---------------------------------------------% +c + betaj = zero + nrstrt = nrstrt + 1 + itry = 1 + 20 continue + rstart = .true. + ido = 0 + 30 continue +c +c %--------------------------------------% +c | If in reverse communication mode and | +c | RSTART = .true. flow returns here. | +c %--------------------------------------% +c + call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, + & resid, rnorm, ipntr, workd, ierr) + if (ido .ne. 99) go to 9000 + if (ierr .lt. 0) then + itry = itry + 1 + if (itry .le. 3) go to 20 +c +c %------------------------------------------------% +c | Give up after several restart attempts. | +c | Set INFO to the size of the invariant subspace | +c | which spans OP and exit. | +c %------------------------------------------------% +c + info = j - 1 + call arsecond (t1) + tnaitr = tnaitr + (t1 - t0) + ido = 99 + go to 9000 + end if +c + 40 continue +c +c %---------------------------------------------------------% +c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | +c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | +c | when reciprocating a small RNORM, test against lower | +c | machine bound. | +c %---------------------------------------------------------% +c + call dcopy (n, resid, 1, v(1,j), 1) + if (rnorm .ge. unfl) then + temp1 = one / rnorm + call dscal (n, temp1, v(1,j), 1) + call dscal (n, temp1, workd(ipj), 1) + else +c +c %-----------------------------------------% +c | To scale both v_{j} and p_{j} carefully | +c | use LAPACK routine SLASCL | +c %-----------------------------------------% +c + call dlascl ('General', i, i, rnorm, one, n, 1, + & v(1,j), n, infol) + call dlascl ('General', i, i, rnorm, one, n, 1, + & workd(ipj), n, infol) + end if +c +c %------------------------------------------------------% +c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | +c | Note that this is not quite yet r_{j}. See STEP 4 | +c %------------------------------------------------------% +c + step3 = .true. + nopx = nopx + 1 + call arsecond (t2) + call dcopy (n, v(1,j), 1, workd(ivj), 1) + ipntr(1) = ivj + ipntr(2) = irj + ipntr(3) = ipj + ido = 1 +c +c %-----------------------------------% +c | Exit in order to compute OP*v_{j} | +c %-----------------------------------% +c + go to 9000 + 50 continue +c +c %----------------------------------% +c | Back from reverse communication; | +c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | +c | if step3 = .true. | +c %----------------------------------% +c + call arsecond (t3) + tmvopx = tmvopx + (t3 - t2) + + step3 = .false. +c +c %------------------------------------------% +c | Put another copy of OP*v_{j} into RESID. | +c %------------------------------------------% +c + call dcopy (n, workd(irj), 1, resid, 1) +c +c %---------------------------------------% +c | STEP 4: Finish extending the Arnoldi | +c | factorization to length j. | +c %---------------------------------------% +c + call arsecond (t2) + if (bmat .eq. 'G') then + nbx = nbx + 1 + step4 = .true. + ipntr(1) = irj + ipntr(2) = ipj + ido = 2 +c +c %-------------------------------------% +c | Exit in order to compute B*OP*v_{j} | +c %-------------------------------------% +c + go to 9000 + else if (bmat .eq. 'I') then + call dcopy (n, resid, 1, workd(ipj), 1) + end if + 60 continue +c +c %----------------------------------% +c | Back from reverse communication; | +c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | +c | if step4 = .true. | +c %----------------------------------% +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c + step4 = .false. +c +c %-------------------------------------% +c | The following is needed for STEP 5. | +c | Compute the B-norm of OP*v_{j}. | +c %-------------------------------------% +c + if (bmat .eq. 'G') then + wnorm = ddot (n, resid, 1, workd(ipj), 1) + wnorm = sqrt(abs(wnorm)) + else if (bmat .eq. 'I') then + wnorm = dnrm2(n, resid, 1) + end if +c +c %-----------------------------------------% +c | Compute the j-th residual corresponding | +c | to the j step factorization. | +c | Use Classical Gram Schmidt and compute: | +c | w_{j} <- V_{j}^T * B * OP * v_{j} | +c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | +c %-----------------------------------------% +c +c +c %------------------------------------------% +c | Compute the j Fourier coefficients w_{j} | +c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | +c %------------------------------------------% +c + call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, + & zero, h(1,j), 1) +c +c %--------------------------------------% +c | Orthogonalize r_{j} against V_{j}. | +c | RESID contains OP*v_{j}. See STEP 3. | +c %--------------------------------------% +c + call dgemv ('N', n, j, -one, v, ldv, h(1,j), 1, + & one, resid, 1) +c + if (j .gt. 1) h(j,j-1) = betaj +c + call arsecond (t4) +c + orth1 = .true. +c + call arsecond (t2) + if (bmat .eq. 'G') then + nbx = nbx + 1 + call dcopy (n, resid, 1, workd(irj), 1) + ipntr(1) = irj + ipntr(2) = ipj + ido = 2 +c +c %----------------------------------% +c | Exit in order to compute B*r_{j} | +c %----------------------------------% +c + go to 9000 + else if (bmat .eq. 'I') then + call dcopy (n, resid, 1, workd(ipj), 1) + end if + 70 continue +c +c %---------------------------------------------------% +c | Back from reverse communication if ORTH1 = .true. | +c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | +c %---------------------------------------------------% +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c + orth1 = .false. +c +c %------------------------------% +c | Compute the B-norm of r_{j}. | +c %------------------------------% +c + if (bmat .eq. 'G') then + rnorm = ddot (n, resid, 1, workd(ipj), 1) + rnorm = sqrt(abs(rnorm)) + else if (bmat .eq. 'I') then + rnorm = dnrm2(n, resid, 1) + end if +c +c %-----------------------------------------------------------% +c | STEP 5: Re-orthogonalization / Iterative refinement phase | +c | Maximum NITER_ITREF tries. | +c | | +c | s = V_{j}^T * B * r_{j} | +c | r_{j} = r_{j} - V_{j}*s | +c | alphaj = alphaj + s_{j} | +c | | +c | The stopping criteria used for iterative refinement is | +c | discussed in Parlett's book SEP, page 107 and in Gragg & | +c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | +c | Determine if we need to correct the residual. The goal is | +c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | +c | The following test determines whether the sine of the | +c | angle between OP*x and the computed residual is less | +c | than or equal to 0.717. | +c %-----------------------------------------------------------% +c + if (rnorm .gt. 0.717*wnorm) go to 100 + iter = 0 + nrorth = nrorth + 1 +c +c %---------------------------------------------------% +c | Enter the Iterative refinement phase. If further | +c | refinement is necessary, loop back here. The loop | +c | variable is ITER. Perform a step of Classical | +c | Gram-Schmidt using all the Arnoldi vectors V_{j} | +c %---------------------------------------------------% +c + 80 continue +c + if (msglvl .gt. 2) then + xtemp(1) = wnorm + xtemp(2) = rnorm + call dvout (logfil, 2, xtemp, ndigit, + & '_naitr: re-orthonalization; wnorm and rnorm are') + call dvout (logfil, j, h(1,j), ndigit, + & '_naitr: j-th column of H') + end if +c +c %----------------------------------------------------% +c | Compute V_{j}^T * B * r_{j}. | +c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | +c %----------------------------------------------------% +c + call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, + & zero, workd(irj), 1) +c +c %---------------------------------------------% +c | Compute the correction to the residual: | +c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | +c | The correction to H is v(:,1:J)*H(1:J,1:J) | +c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | +c %---------------------------------------------% +c + call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, + & one, resid, 1) + call daxpy (j, one, workd(irj), 1, h(1,j), 1) +c + orth2 = .true. + call arsecond (t2) + if (bmat .eq. 'G') then + nbx = nbx + 1 + call dcopy (n, resid, 1, workd(irj), 1) + ipntr(1) = irj + ipntr(2) = ipj + ido = 2 +c +c %-----------------------------------% +c | Exit in order to compute B*r_{j}. | +c | r_{j} is the corrected residual. | +c %-----------------------------------% +c + go to 9000 + else if (bmat .eq. 'I') then + call dcopy (n, resid, 1, workd(ipj), 1) + end if + 90 continue +c +c %---------------------------------------------------% +c | Back from reverse communication if ORTH2 = .true. | +c %---------------------------------------------------% +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c +c %-----------------------------------------------------% +c | Compute the B-norm of the corrected residual r_{j}. | +c %-----------------------------------------------------% +c + if (bmat .eq. 'G') then + rnorm1 = ddot (n, resid, 1, workd(ipj), 1) + rnorm1 = sqrt(abs(rnorm1)) + else if (bmat .eq. 'I') then + rnorm1 = dnrm2(n, resid, 1) + end if +c + if (msglvl .gt. 0 .and. iter .gt. 0) then + call ivout (logfil, 1, [j], ndigit, + & '_naitr: Iterative refinement for Arnoldi residual') + if (msglvl .gt. 2) then + xtemp(1) = rnorm + xtemp(2) = rnorm1 + call dvout (logfil, 2, xtemp, ndigit, + & '_naitr: iterative refinement ; rnorm and rnorm1 are') + end if + end if +c +c %-----------------------------------------% +c | Determine if we need to perform another | +c | step of re-orthogonalization. | +c %-----------------------------------------% +c + if (rnorm1 .gt. 0.717*rnorm) then +c +c %---------------------------------------% +c | No need for further refinement. | +c | The cosine of the angle between the | +c | corrected residual vector and the old | +c | residual vector is greater than 0.717 | +c | In other words the corrected residual | +c | and the old residual vector share an | +c | angle of less than arcCOS(0.717) | +c %---------------------------------------% +c + rnorm = rnorm1 +c + else +c +c %-------------------------------------------% +c | Another step of iterative refinement step | +c | is required. NITREF is used by stat.h | +c %-------------------------------------------% +c + nitref = nitref + 1 + rnorm = rnorm1 + iter = iter + 1 + if (iter .le. 1) go to 80 +c +c %-------------------------------------------------% +c | Otherwise RESID is numerically in the span of V | +c %-------------------------------------------------% +c + do 95 jj = 1, n + resid(jj) = zero + 95 continue + rnorm = zero + end if +c +c %----------------------------------------------% +c | Branch here directly if iterative refinement | +c | wasn't necessary or after at most NITER_REF | +c | steps of iterative refinement. | +c %----------------------------------------------% +c + 100 continue +c + rstart = .false. + orth2 = .false. +c + call arsecond (t5) + titref = titref + (t5 - t4) +c +c %------------------------------------% +c | STEP 6: Update j = j+1; Continue | +c %------------------------------------% +c + j = j + 1 + if (j .gt. k+np) then + call arsecond (t1) + tnaitr = tnaitr + (t1 - t0) + ido = 99 + do 110 i = max(1,k), k+np-1 +c +c %--------------------------------------------% +c | Check for splitting and deflation. | +c | Use a standard test as in the QR algorithm | +c | REFERENCE: LAPACK subroutine dlahqr | +c %--------------------------------------------% +c + tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) + if( tst1.eq.zero ) + & tst1 = dlanhs( '1', k+np, h, ldh, workd(n+1) ) + if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) + & h(i+1,i) = zero + 110 continue +c + if (msglvl .gt. 2) then + call dmout (logfil, k+np, k+np, h, ldh, ndigit, + & '_naitr: Final upper Hessenberg matrix H of order K+NP') + end if +c + go to 9000 + end if +c +c %--------------------------------------------------------% +c | Loop back to extend the factorization by another step. | +c %--------------------------------------------------------% +c + go to 1000 +c +c %---------------------------------------------------------------% +c | | +c | E N D O F M A I N I T E R A T I O N L O O P | +c | | +c %---------------------------------------------------------------% +c + 9000 continue + return +c +c %---------------% +c | End of dnaitr | +c %---------------% +c + end diff --git a/src/arpack/dnapps.f b/src/arpack/dnapps.f new file mode 100644 index 0000000000..3338818867 --- /dev/null +++ b/src/arpack/dnapps.f @@ -0,0 +1,647 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dnapps +c +c\Description: +c Given the Arnoldi factorization +c +c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, +c +c apply NP implicit shifts resulting in +c +c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q +c +c where Q is an orthogonal matrix which is the product of rotations +c and reflections resulting from the NP bulge chage sweeps. +c The updated Arnoldi factorization becomes: +c +c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. +c +c\Usage: +c call dnapps +c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ, +c WORKL, WORKD ) +c +c\Arguments +c N Integer. (INPUT) +c Problem size, i.e. size of matrix A. +c +c KEV Integer. (INPUT/OUTPUT) +c KEV+NP is the size of the input matrix H. +c KEV is the size of the updated matrix HNEW. KEV is only +c updated on ouput when fewer than NP shifts are applied in +c order to keep the conjugate pair together. +c +c NP Integer. (INPUT) +c Number of implicit shifts to be applied. +c +c SHIFTR, Double precision array of length NP. (INPUT) +c SHIFTI Real and imaginary part of the shifts to be applied. +c Upon, entry to dnapps, the shifts must be sorted so that the +c conjugate pairs are in consecutive locations. +c +c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) +c On INPUT, V contains the current KEV+NP Arnoldi vectors. +c On OUTPUT, V contains the updated KEV Arnoldi vectors +c in the first KEV columns of V. +c +c LDV Integer. (INPUT) +c Leading dimension of V exactly as declared in the calling +c program. +c +c H Double precision (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) +c On INPUT, H contains the current KEV+NP by KEV+NP upper +c Hessenber matrix of the Arnoldi factorization. +c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg +c matrix in the KEV leading submatrix. +c +c LDH Integer. (INPUT) +c Leading dimension of H exactly as declared in the calling +c program. +c +c RESID Double precision array of length N. (INPUT/OUTPUT) +c On INPUT, RESID contains the the residual vector r_{k+p}. +c On OUTPUT, RESID is the update residual vector rnew_{k} +c in the first KEV locations. +c +c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) +c Work array used to accumulate the rotations and reflections +c during the bulge chase sweep. +c +c LDQ Integer. (INPUT) +c Leading dimension of Q exactly as declared in the calling +c program. +c +c WORKL Double precision work array of length (KEV+NP). (WORKSPACE) +c Private (replicated) array on each PE or array allocated on +c the front end. +c +c WORKD Double precision work array of length 2*N. (WORKSPACE) +c Distributed array used in the application of the accumulated +c orthogonal matrix Q. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c +c\Routines called: +c ivout ARPACK utility routine that prints integers. +c second ARPACK utility routine for timing. +c dmout ARPACK utility routine that prints matrices. +c dvout ARPACK utility routine that prints vectors. +c dlabad LAPACK routine that computes machine constants. +c dlacpy LAPACK matrix copy routine. +c dlamch LAPACK routine that determines machine constants. +c dlanhs LAPACK routine that computes various norms of a matrix. +c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +c dlarf LAPACK routine that applies Householder reflection to +c a matrix. +c dlarfg LAPACK Householder reflection construction routine. +c dlartg LAPACK Givens rotation construction routine. +c dlaset LAPACK matrix initialization routine. +c dgemv Level 2 BLAS routine for matrix vector multiplication. +c daxpy Level 1 BLAS that computes a vector triad. +c dcopy Level 1 BLAS that copies one vector to another . +c dscal Level 1 BLAS that scales a vector. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/92: Version ' 2.4' +c +c\SCCS Information: @(#) +c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2 +c +c\Remarks +c 1. In this version, each shift is applied to all the sublocks of +c the Hessenberg matrix H and not just to the submatrix that it +c comes from. Deflation as in LAPACK routine dlahqr (QR algorithm +c for upper Hessenberg matrices ) is used. +c The subdiagonals of H are enforced to be non-negative. +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dnapps + & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq, + & workl, workd ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + integer kev, ldh, ldq, ldv, n, np +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & h(ldh,kev+np), resid(n), shifti(np), shiftr(np), + & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %------------------------% +c | Local Scalars & Arrays | +c %------------------------% +c + integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr + logical cconj, first + Double precision + & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai, + & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1 + save first, ovfl, smlnum, ulp, unfl +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external daxpy, dcopy, dscal, dlacpy, dlarfg, dlarf, + & dlaset, dlabad, second, dlartg +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dlamch, dlanhs, dlapy2 + external dlamch, dlanhs, dlapy2 +c +c %----------------------% +c | Intrinsics Functions | +c %----------------------% +c + intrinsic abs, max, min +c +c %----------------% +c | Data statments | +c %----------------% +c + data first / .true. / +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + if (first) then +c +c %-----------------------------------------------% +c | Set machine-dependent constants for the | +c | stopping criterion. If norm(H) <= sqrt(OVFL), | +c | overflow should not occur. | +c | REFERENCE: LAPACK subroutine dlahqr | +c %-----------------------------------------------% +c + unfl = dlamch( 'safe minimum' ) + ovfl = one / unfl + call dlabad( unfl, ovfl ) + ulp = dlamch( 'precision' ) + smlnum = unfl*( n / ulp ) + first = .false. + end if +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = mnapps + kplusp = kev + np +c +c %--------------------------------------------% +c | Initialize Q to the identity to accumulate | +c | the rotations and reflections | +c %--------------------------------------------% +c + call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) +c +c %----------------------------------------------% +c | Quick return if there are no shifts to apply | +c %----------------------------------------------% +c + if (np .eq. 0) go to 9000 +c +c %----------------------------------------------% +c | Chase the bulge with the application of each | +c | implicit shift. Each shift is applied to the | +c | whole matrix including each block. | +c %----------------------------------------------% +c + cconj = .false. + do 110 jj = 1, np + sigmar = shiftr(jj) + sigmai = shifti(jj) +c + if (msglvl .gt. 2 ) then + call ivout (logfil, 1, [jj], ndigit, + & '_napps: shift number.') + call dvout (logfil, 1, [sigmar], ndigit, + & '_napps: The real part of the shift ') + call dvout (logfil, 1, [sigmai], ndigit, + & '_napps: The imaginary part of the shift ') + end if +c +c %-------------------------------------------------% +c | The following set of conditionals is necessary | +c | in order that complex conjugate pairs of shifts | +c | are applied together or not at all. | +c %-------------------------------------------------% +c + if ( cconj ) then +c +c %-----------------------------------------% +c | cconj = .true. means the previous shift | +c | had non-zero imaginary part. | +c %-----------------------------------------% +c + cconj = .false. + go to 110 + else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then +c +c %------------------------------------% +c | Start of a complex conjugate pair. | +c %------------------------------------% +c + cconj = .true. + else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then +c +c %----------------------------------------------% +c | The last shift has a nonzero imaginary part. | +c | Don't apply it; thus the order of the | +c | compressed H is order KEV+1 since only np-1 | +c | were applied. | +c %----------------------------------------------% +c + kev = kev + 1 + go to 110 + end if + istart = 1 + 20 continue +c +c %--------------------------------------------------% +c | if sigmai = 0 then | +c | Apply the jj-th shift ... | +c | else | +c | Apply the jj-th and (jj+1)-th together ... | +c | (Note that jj < np at this point in the code) | +c | end | +c | to the current block of H. The next do loop | +c | determines the current block ; | +c %--------------------------------------------------% +c + do 30 i = istart, kplusp-1 +c +c %----------------------------------------% +c | Check for splitting and deflation. Use | +c | a standard test as in the QR algorithm | +c | REFERENCE: LAPACK subroutine dlahqr | +c %----------------------------------------% +c + tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) + if( tst1.eq.zero ) + & tst1 = dlanhs( '1', kplusp-jj+1, h, ldh, workl ) + if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then + if (msglvl .gt. 0) then + call ivout (logfil, 1, [i], ndigit, + & '_napps: matrix splitting at row/column no.') + call ivout (logfil, 1, [jj], ndigit, + & '_napps: matrix splitting with shift number.') + call dvout (logfil, 1, h(i+1,i), ndigit, + & '_napps: off diagonal element.') + end if + iend = i + h(i+1,i) = zero + go to 40 + end if + 30 continue + iend = kplusp + 40 continue +c + if (msglvl .gt. 2) then + call ivout (logfil, 1, [istart], ndigit, + & '_napps: Start of current block ') + call ivout (logfil, 1, [iend], ndigit, + & '_napps: End of current block ') + end if +c +c %------------------------------------------------% +c | No reason to apply a shift to block of order 1 | +c %------------------------------------------------% +c + if ( istart .eq. iend ) go to 100 +c +c %------------------------------------------------------% +c | If istart + 1 = iend then no reason to apply a | +c | complex conjugate pair of shifts on a 2 by 2 matrix. | +c %------------------------------------------------------% +c + if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero ) + & go to 100 +c + h11 = h(istart,istart) + h21 = h(istart+1,istart) + if ( abs( sigmai ) .le. zero ) then +c +c %---------------------------------------------% +c | Real-valued shift ==> apply single shift QR | +c %---------------------------------------------% +c + f = h11 - sigmar + g = h21 +c + do 80 i = istart, iend-1 +c +c %-----------------------------------------------------% +c | Contruct the plane rotation G to zero out the bulge | +c %-----------------------------------------------------% +c + call dlartg (f, g, c, s, r) + if (i .gt. istart) then +c +c %-------------------------------------------% +c | The following ensures that h(1:iend-1,1), | +c | the first iend-2 off diagonal of elements | +c | H, remain non negative. | +c %-------------------------------------------% +c + if (r .lt. zero) then + r = -r + c = -c + s = -s + end if + h(i,i-1) = r + h(i+1,i-1) = zero + end if +c +c %---------------------------------------------% +c | Apply rotation to the left of H; H <- G'*H | +c %---------------------------------------------% +c + do 50 j = i, kplusp + t = c*h(i,j) + s*h(i+1,j) + h(i+1,j) = -s*h(i,j) + c*h(i+1,j) + h(i,j) = t + 50 continue +c +c %---------------------------------------------% +c | Apply rotation to the right of H; H <- H*G | +c %---------------------------------------------% +c + do 60 j = 1, min(i+2,iend) + t = c*h(j,i) + s*h(j,i+1) + h(j,i+1) = -s*h(j,i) + c*h(j,i+1) + h(j,i) = t + 60 continue +c +c %----------------------------------------------------% +c | Accumulate the rotation in the matrix Q; Q <- Q*G | +c %----------------------------------------------------% +c + do 70 j = 1, min( i+jj, kplusp ) + t = c*q(j,i) + s*q(j,i+1) + q(j,i+1) = - s*q(j,i) + c*q(j,i+1) + q(j,i) = t + 70 continue +c +c %---------------------------% +c | Prepare for next rotation | +c %---------------------------% +c + if (i .lt. iend-1) then + f = h(i+1,i) + g = h(i+2,i) + end if + 80 continue +c +c %-----------------------------------% +c | Finished applying the real shift. | +c %-----------------------------------% +c + else +c +c %----------------------------------------------------% +c | Complex conjugate shifts ==> apply double shift QR | +c %----------------------------------------------------% +c + h12 = h(istart,istart+1) + h22 = h(istart+1,istart+1) + h32 = h(istart+2,istart+1) +c +c %---------------------------------------------------------% +c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | +c %---------------------------------------------------------% +c + s = 2.0*sigmar + t = dlapy2 ( sigmar, sigmai ) + u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12 + u(2) = h11 + h22 - s + u(3) = h32 +c + do 90 i = istart, iend-1 +c + nr = min ( 3, iend-i+1 ) +c +c %-----------------------------------------------------% +c | Construct Householder reflector G to zero out u(1). | +c | G is of the form I - tau*( 1 u )' * ( 1 u' ). | +c %-----------------------------------------------------% +c + call dlarfg ( nr, u(1), u(2), 1, tau ) +c + if (i .gt. istart) then + h(i,i-1) = u(1) + h(i+1,i-1) = zero + if (i .lt. iend-1) h(i+2,i-1) = zero + end if + u(1) = one +c +c %--------------------------------------% +c | Apply the reflector to the left of H | +c %--------------------------------------% +c + call dlarf ('Left', nr, kplusp-i+1, u, 1, tau, + & h(i,i), ldh, workl) +c +c %---------------------------------------% +c | Apply the reflector to the right of H | +c %---------------------------------------% +c + ir = min ( i+3, iend ) + call dlarf ('Right', ir, nr, u, 1, tau, + & h(1,i), ldh, workl) +c +c %-----------------------------------------------------% +c | Accumulate the reflector in the matrix Q; Q <- Q*G | +c %-----------------------------------------------------% +c + call dlarf ('Right', kplusp, nr, u, 1, tau, + & q(1,i), ldq, workl) +c +c %----------------------------% +c | Prepare for next reflector | +c %----------------------------% +c + if (i .lt. iend-1) then + u(1) = h(i+1,i) + u(2) = h(i+2,i) + if (i .lt. iend-2) u(3) = h(i+3,i) + end if +c + 90 continue +c +c %--------------------------------------------% +c | Finished applying a complex pair of shifts | +c | to the current block | +c %--------------------------------------------% +c + end if +c + 100 continue +c +c %---------------------------------------------------------% +c | Apply the same shift to the next block if there is any. | +c %---------------------------------------------------------% +c + istart = iend + 1 + if (iend .lt. kplusp) go to 20 +c +c %---------------------------------------------% +c | Loop back to the top to get the next shift. | +c %---------------------------------------------% +c + 110 continue +c +c %--------------------------------------------------% +c | Perform a similarity transformation that makes | +c | sure that H will have non negative sub diagonals | +c %--------------------------------------------------% +c + do 120 j=1,kev + if ( h(j+1,j) .lt. zero ) then + call dscal( kplusp-j+1, -one, h(j+1,j), ldh ) + call dscal( min(j+2, kplusp), -one, h(1,j+1), 1 ) + call dscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 ) + end if + 120 continue +c + do 130 i = 1, kev +c +c %--------------------------------------------% +c | Final check for splitting and deflation. | +c | Use a standard test as in the QR algorithm | +c | REFERENCE: LAPACK subroutine dlahqr | +c %--------------------------------------------% +c + tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) + if( tst1.eq.zero ) + & tst1 = dlanhs( '1', kev, h, ldh, workl ) + if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) ) + & h(i+1,i) = zero + 130 continue +c +c %-------------------------------------------------% +c | Compute the (kev+1)-st column of (V*Q) and | +c | temporarily store the result in WORKD(N+1:2*N). | +c | This is needed in the residual update since we | +c | cannot GUARANTEE that the corresponding entry | +c | of H would be zero as in exact arithmetic. | +c %-------------------------------------------------% +c + if (h(kev+1,kev) .gt. zero) + & call dgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, + & workd(n+1), 1) +c +c %----------------------------------------------------------% +c | Compute column 1 to kev of (V*Q) in backward order | +c | taking advantage of the upper Hessenberg structure of Q. | +c %----------------------------------------------------------% +c + do 140 i = 1, kev + call dgemv ('N', n, kplusp-i+1, one, v, ldv, + & q(1,kev-i+1), 1, zero, workd, 1) + call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) + 140 continue +c +c %-------------------------------------------------% +c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | +c %-------------------------------------------------% +c + call dlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) +c +c %--------------------------------------------------------------% +c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | +c %--------------------------------------------------------------% +c + if (h(kev+1,kev) .gt. zero) + & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) +c +c %-------------------------------------% +c | Update the residual vector: | +c | r <- sigmak*r + betak*v(:,kev+1) | +c | where | +c | sigmak = (e_{kplusp}'*Q)*e_{kev} | +c | betak = e_{kev+1}'*H*e_{kev} | +c %-------------------------------------% +c + call dscal (n, q(kplusp,kev), resid, 1) + if (h(kev+1,kev) .gt. zero) + & call daxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) +c + if (msglvl .gt. 1) then + call dvout (logfil, 1, q(kplusp,kev), ndigit, + & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') + call dvout (logfil, 1, h(kev+1,kev), ndigit, + & '_napps: betak = e_{kev+1}^T*H*e_{kev}') + call ivout (logfil, 1, [kev], ndigit, + & '_napps: Order of the final Hessenberg matrix ') + if (msglvl .gt. 2) then + call dmout (logfil, kev, kev, h, ldh, ndigit, + & '_napps: updated Hessenberg matrix H for next iteration') + end if +c + end if +c + 9000 continue + call arsecond (t1) + tnapps = tnapps + (t1 - t0) +c + return +c +c %---------------% +c | End of dnapps | +c %---------------% +c + end diff --git a/src/arpack/dnaup2.f b/src/arpack/dnaup2.f new file mode 100644 index 0000000000..5efdf1a487 --- /dev/null +++ b/src/arpack/dnaup2.f @@ -0,0 +1,835 @@ +c\BeginDoc +c +c\Name: dnaup2 +c +c\Description: +c Intermediate level interface called by dnaupd. +c +c\Usage: +c call dnaup2 +c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, +c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS, +c Q, LDQ, WORKL, IPNTR, WORKD, INFO ) +c +c\Arguments +c +c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dnaupd. +c MODE, ISHIFT, MXITER: see the definition of IPARAM in dnaupd. +c +c NP Integer. (INPUT/OUTPUT) +c Contains the number of implicit shifts to apply during +c each Arnoldi iteration. +c If ISHIFT=1, NP is adjusted dynamically at each iteration +c to accelerate convergence and prevent stagnation. +c This is also roughly equal to the number of matrix-vector +c products (involving the operator OP) per Arnoldi iteration. +c The logic for adjusting is contained within the current +c subroutine. +c If ISHIFT=0, NP is the number of shifts the user needs +c to provide via reverse comunication. 0 < NP < NCV-NEV. +c NP may be less than NCV-NEV for two reasons. The first, is +c to keep complex conjugate pairs of "wanted" Ritz values +c together. The second, is that a leading block of the current +c upper Hessenberg matrix has split off and contains "unwanted" +c Ritz values. +c Upon termination of the IRA iteration, NP contains the number +c of "converged" wanted Ritz values. +c +c IUPD Integer. (INPUT) +c IUPD .EQ. 0: use explicit restart instead implicit update. +c IUPD .NE. 0: use implicit update. +c +c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) +c The Arnoldi basis vectors are returned in the first NEV +c columns of V. +c +c LDV Integer. (INPUT) +c Leading dimension of V exactly as declared in the calling +c program. +c +c H Double precision (NEV+NP) by (NEV+NP) array. (OUTPUT) +c H is used to store the generated upper Hessenberg matrix +c +c LDH Integer. (INPUT) +c Leading dimension of H exactly as declared in the calling +c program. +c +c RITZR, Double precision arrays of length NEV+NP. (OUTPUT) +c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp. +c imaginary) part of the computed Ritz values of OP. +c +c BOUNDS Double precision array of length NEV+NP. (OUTPUT) +c BOUNDS(1:NEV) contain the error bounds corresponding to +c the computed Ritz values. +c +c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) +c Private (replicated) work array used to accumulate the +c rotation in the shift application step. +c +c LDQ Integer. (INPUT) +c Leading dimension of Q exactly as declared in the calling +c program. +c +c WORKL Double precision work array of length at least +c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE) +c Private (replicated) array on each PE or array allocated on +c the front end. It is used in shifts calculation, shifts +c application and convergence checking. +c +c On exit, the last 3*(NEV+NP) locations of WORKL contain +c the Ritz values (real,imaginary) and associated Ritz +c estimates of the current Hessenberg matrix. They are +c listed in the same order as returned from dneigh. +c +c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations +c of WORKL are used in reverse communication to hold the user +c supplied shifts. +c +c IPNTR Integer array of length 3. (OUTPUT) +c Pointer to mark the starting locations in the WORKD for +c vectors used by the Arnoldi iteration. +c ------------------------------------------------------------- +c IPNTR(1): pointer to the current operand vector X. +c IPNTR(2): pointer to the current result vector Y. +c IPNTR(3): pointer to the vector B * X when used in the +c shift-and-invert mode. X is the current operand. +c ------------------------------------------------------------- +c +c WORKD Double precision work array of length 3*N. (WORKSPACE) +c Distributed array to be used in the basic Arnoldi iteration +c for reverse communication. The user should not use WORKD +c as temporary workspace during the iteration !!!!!!!!!! +c See Data Distribution Note in DNAUPD. +c +c INFO Integer. (INPUT/OUTPUT) +c If INFO .EQ. 0, a randomly initial residual vector is used. +c If INFO .NE. 0, RESID contains the initial residual vector, +c possibly from a previous run. +c Error flag on output. +c = 0: Normal return. +c = 1: Maximum number of iterations taken. +c All possible eigenvalues of OP has been found. +c NP returns the number of converged Ritz values. +c = 2: No shifts could be applied. +c = -8: Error return from LAPACK eigenvalue calculation; +c This should never happen. +c = -9: Starting vector is zero. +c = -9999: Could not build an Arnoldi factorization. +c Size that was built in returned in NP. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +c Restarted Arnoldi Iteration", Rice University Technical Report +c TR95-13, Department of Computational and Applied Mathematics. +c +c\Routines called: +c dgetv0 ARPACK initial vector generation routine. +c dnaitr ARPACK Arnoldi factorization routine. +c dnapps ARPACK application of implicit shifts routine. +c dnconv ARPACK convergence of Ritz values routine. +c dneigh ARPACK compute Ritz values and error bounds routine. +c dngets ARPACK reorder Ritz values and error bounds routine. +c dsortc ARPACK sorting routine. +c ivout ARPACK utility routine that prints integers. +c second ARPACK utility routine for timing. +c dmout ARPACK utility routine that prints matrices +c dvout ARPACK utility routine that prints vectors. +c dlamch LAPACK routine that determines machine constants. +c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +c dcopy Level 1 BLAS that copies one vector to another . +c ddot Level 1 BLAS that computes the scalar product of two vectors. +c dnrm2 Level 1 BLAS that computes the norm of a vector. +c dswap Level 1 BLAS that swaps two vectors. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\SCCS Information: @(#) +c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2 +c +c\Remarks +c 1. None +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dnaup2 + & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, + & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds, + & q, ldq, workl, ipntr, workd, info ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character bmat*1, which*2 + integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, + & n, nev, np + Double precision + & tol +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + integer ipntr(13) + Double precision + & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n), + & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np), + & workd(3*n), workl( (nev+np)*(nev+np+3) ) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + character wprime*2 + logical cnorm , getv0, initv, update, ushift + integer ierr , iter , j , kplusp, msglvl, nconv, + & nevbef, nev0 , np0 , nptemp, numcnv + Double precision + & rnorm , temp , eps23 + save cnorm , getv0, initv, update, ushift, + & rnorm , iter , eps23, kplusp, msglvl, nconv , + & nevbef, nev0 , np0 , numcnv +c +c %-----------------------% +c | Local array arguments | +c %-----------------------% +c + integer kp(4) +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dcopy , dgetv0, dnaitr, dnconv, dneigh, + & dngets, dnapps, dvout , ivout , second +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & ddot, dnrm2, dlapy2, dlamch + external ddot, dnrm2, dlapy2, dlamch +c +c %---------------------% +c | Intrinsic Functions | +c %---------------------% +c + intrinsic min, max, abs, sqrt +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + if (ido .eq. 0) then +c + call arsecond (t0) +c + msglvl = mnaup2 +c +c %-------------------------------------% +c | Get the machine dependent constant. | +c %-------------------------------------% +c + eps23 = dlamch('Epsilon-Machine') + eps23 = eps23**(2.0D+0 / 3.0D+0) +c + nev0 = nev + np0 = np +c +c %-------------------------------------% +c | kplusp is the bound on the largest | +c | Lanczos factorization built. | +c | nconv is the current number of | +c | "converged" eigenvlues. | +c | iter is the counter on the current | +c | iteration step. | +c %-------------------------------------% +c + kplusp = nev + np + nconv = 0 + iter = 0 +c +c %---------------------------------------% +c | Set flags for computing the first NEV | +c | steps of the Arnoldi factorization. | +c %---------------------------------------% +c + getv0 = .true. + update = .false. + ushift = .false. + cnorm = .false. +c + if (info .ne. 0) then +c +c %--------------------------------------------% +c | User provides the initial residual vector. | +c %--------------------------------------------% +c + initv = .true. + info = 0 + else + initv = .false. + end if + end if +c +c %---------------------------------------------% +c | Get a possibly random starting vector and | +c | force it into the range of the operator OP. | +c %---------------------------------------------% +c + 10 continue +c + if (getv0) then + call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, + & ipntr, workd, info) +c + if (ido .ne. 99) go to 9000 +c + if (rnorm .eq. zero) then +c +c %-----------------------------------------% +c | The initial vector is zero. Error exit. | +c %-----------------------------------------% +c + info = -9 + go to 1100 + end if + getv0 = .false. + ido = 0 + end if +c +c %-----------------------------------% +c | Back from reverse communication : | +c | continue with update step | +c %-----------------------------------% +c + if (update) go to 20 +c +c %-------------------------------------------% +c | Back from computing user specified shifts | +c %-------------------------------------------% +c + if (ushift) go to 50 +c +c %-------------------------------------% +c | Back from computing residual norm | +c | at the end of the current iteration | +c %-------------------------------------% +c + if (cnorm) go to 100 +c +c %----------------------------------------------------------% +c | Compute the first NEV steps of the Arnoldi factorization | +c %----------------------------------------------------------% +c + call dnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, + & h, ldh, ipntr, workd, info) +c +c %---------------------------------------------------% +c | ido .ne. 99 implies use of reverse communication | +c | to compute operations involving OP and possibly B | +c %---------------------------------------------------% +c + if (ido .ne. 99) go to 9000 +c + if (info .gt. 0) then + np = info + mxiter = iter + info = -9999 + go to 1200 + end if +c +c %--------------------------------------------------------------% +c | | +c | M A I N ARNOLDI I T E R A T I O N L O O P | +c | Each iteration implicitly restarts the Arnoldi | +c | factorization in place. | +c | | +c %--------------------------------------------------------------% +c + 1000 continue +c + iter = iter + 1 +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [iter], ndigit, + & '_naup2: **** Start of major iteration number ****') + end if +c +c %-----------------------------------------------------------% +c | Compute NP additional steps of the Arnoldi factorization. | +c | Adjust NP since NEV might have been updated by last call | +c | to the shift application routine dnapps. | +c %-----------------------------------------------------------% +c + np = kplusp - nev +c + if (msglvl .gt. 1) then + call ivout (logfil, 1, [nev], ndigit, + & '_naup2: The length of the current Arnoldi factorization') + call ivout (logfil, 1, [np], ndigit, + & '_naup2: Extend the Arnoldi factorization by') + end if +c +c %-----------------------------------------------------------% +c | Compute NP additional steps of the Arnoldi factorization. | +c %-----------------------------------------------------------% +c + ido = 0 + 20 continue + update = .true. +c + call dnaitr (ido , bmat, n , nev, np , mode , resid, + & rnorm, v , ldv, h , ldh, ipntr, workd, + & info) +c +c %---------------------------------------------------% +c | ido .ne. 99 implies use of reverse communication | +c | to compute operations involving OP and possibly B | +c %---------------------------------------------------% +c + if (ido .ne. 99) go to 9000 +c + if (info .gt. 0) then + np = info + mxiter = iter + info = -9999 + go to 1200 + end if + update = .false. +c + if (msglvl .gt. 1) then + call dvout (logfil, 1, [rnorm], ndigit, + & '_naup2: Corresponding B-norm of the residual') + end if +c +c %--------------------------------------------------------% +c | Compute the eigenvalues and corresponding error bounds | +c | of the current upper Hessenberg matrix. | +c %--------------------------------------------------------% +c + call dneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds, + & q, ldq, workl, ierr) +c + if (ierr .ne. 0) then + info = -8 + go to 1200 + end if +c +c %----------------------------------------------------% +c | Make a copy of eigenvalues and corresponding error | +c | bounds obtained from dneigh. | +c %----------------------------------------------------% +c + call dcopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1) + call dcopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1) + call dcopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1) +c +c %---------------------------------------------------% +c | Select the wanted Ritz values and their bounds | +c | to be used in the convergence test. | +c | The wanted part of the spectrum and corresponding | +c | error bounds are in the last NEV loc. of RITZR, | +c | RITZI and BOUNDS respectively. The variables NEV | +c | and NP may be updated if the NEV-th wanted Ritz | +c | value has a non zero imaginary part. In this case | +c | NEV is increased by one and NP decreased by one. | +c | NOTE: The last two arguments of dngets are no | +c | longer used as of version 2.1. | +c %---------------------------------------------------% +c + nev = nev0 + np = np0 + numcnv = nev + call dngets (ishift, which, nev, np, ritzr, ritzi, + & bounds, workl, workl(np+1)) + if (nev .eq. nev0+1) numcnv = nev0+1 +c +c %-------------------% +c | Convergence test. | +c %-------------------% +c + call dcopy (nev, bounds(np+1), 1, workl(2*np+1), 1) + call dnconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1), + & tol, nconv) +c + if (msglvl .gt. 2) then + kp(1) = nev + kp(2) = np + kp(3) = numcnv + kp(4) = nconv + call ivout (logfil, 4, kp, ndigit, + & '_naup2: NEV, NP, NUMCNV, NCONV are') + call dvout (logfil, kplusp, ritzr, ndigit, + & '_naup2: Real part of the eigenvalues of H') + call dvout (logfil, kplusp, ritzi, ndigit, + & '_naup2: Imaginary part of the eigenvalues of H') + call dvout (logfil, kplusp, bounds, ndigit, + & '_naup2: Ritz estimates of the current NCV Ritz values') + end if +c +c %---------------------------------------------------------% +c | Count the number of unwanted Ritz values that have zero | +c | Ritz estimates. If any Ritz estimates are equal to zero | +c | then a leading block of H of order equal to at least | +c | the number of Ritz values with zero Ritz estimates has | +c | split off. None of these Ritz values may be removed by | +c | shifting. Decrease NP the number of shifts to apply. If | +c | no shifts may be applied, then prepare to exit | +c %---------------------------------------------------------% +c + nptemp = np + do 30 j=1, nptemp + if (bounds(j) .eq. zero) then + np = np - 1 + nev = nev + 1 + end if + 30 continue +c + if ( (nconv .ge. numcnv) .or. + & (iter .gt. mxiter) .or. + & (np .eq. 0) ) then +c + if (msglvl .gt. 4) then + call dvout(logfil, kplusp, workl(kplusp**2+1), ndigit, + & '_naup2: Real part of the eig computed by _neigh:') + call dvout(logfil, kplusp, workl(kplusp**2+kplusp+1), + & ndigit, + & '_naup2: Imag part of the eig computed by _neigh:') + call dvout(logfil, kplusp, workl(kplusp**2+kplusp*2+1), + & ndigit, + & '_naup2: Ritz eistmates computed by _neigh:') + end if +c +c %------------------------------------------------% +c | Prepare to exit. Put the converged Ritz values | +c | and corresponding bounds in RITZ(1:NCONV) and | +c | BOUNDS(1:NCONV) respectively. Then sort. Be | +c | careful when NCONV > NP | +c %------------------------------------------------% +c +c %------------------------------------------% +c | Use h( 3,1 ) as storage to communicate | +c | rnorm to _neupd if needed | +c %------------------------------------------% + + h(3,1) = rnorm +c +c %----------------------------------------------% +c | To be consistent with dngets, we first do a | +c | pre-processing sort in order to keep complex | +c | conjugate pairs together. This is similar | +c | to the pre-processing sort used in dngets | +c | except that the sort is done in the opposite | +c | order. | +c %----------------------------------------------% +c + if (which .eq. 'LM') wprime = 'SR' + if (which .eq. 'SM') wprime = 'LR' + if (which .eq. 'LR') wprime = 'SM' + if (which .eq. 'SR') wprime = 'LM' + if (which .eq. 'LI') wprime = 'SM' + if (which .eq. 'SI') wprime = 'LM' +c + call dsortc (wprime, .true., kplusp, ritzr, ritzi, bounds) +c +c %----------------------------------------------% +c | Now sort Ritz values so that converged Ritz | +c | values appear within the first NEV locations | +c | of ritzr, ritzi and bounds, and the most | +c | desired one appears at the front. | +c %----------------------------------------------% +c + if (which .eq. 'LM') wprime = 'SM' + if (which .eq. 'SM') wprime = 'LM' + if (which .eq. 'LR') wprime = 'SR' + if (which .eq. 'SR') wprime = 'LR' + if (which .eq. 'LI') wprime = 'SI' + if (which .eq. 'SI') wprime = 'LI' +c + call dsortc(wprime, .true., kplusp, ritzr, ritzi, bounds) +c +c %--------------------------------------------------% +c | Scale the Ritz estimate of each Ritz value | +c | by 1 / max(eps23,magnitude of the Ritz value). | +c %--------------------------------------------------% +c + do 35 j = 1, numcnv + temp = max(eps23,dlapy2(ritzr(j), + & ritzi(j))) + bounds(j) = bounds(j)/temp + 35 continue +c +c %----------------------------------------------------% +c | Sort the Ritz values according to the scaled Ritz | +c | esitmates. This will push all the converged ones | +c | towards the front of ritzr, ritzi, bounds | +c | (in the case when NCONV < NEV.) | +c %----------------------------------------------------% +c + wprime = 'LR' + call dsortc(wprime, .true., numcnv, bounds, ritzr, ritzi) +c +c %----------------------------------------------% +c | Scale the Ritz estimate back to its original | +c | value. | +c %----------------------------------------------% +c + do 40 j = 1, numcnv + temp = max(eps23, dlapy2(ritzr(j), + & ritzi(j))) + bounds(j) = bounds(j)*temp + 40 continue +c +c %------------------------------------------------% +c | Sort the converged Ritz values again so that | +c | the "threshold" value appears at the front of | +c | ritzr, ritzi and bound. | +c %------------------------------------------------% +c + call dsortc(which, .true., nconv, ritzr, ritzi, bounds) +c + if (msglvl .gt. 1) then + call dvout (logfil, kplusp, ritzr, ndigit, + & '_naup2: Sorted real part of the eigenvalues') + call dvout (logfil, kplusp, ritzi, ndigit, + & '_naup2: Sorted imaginary part of the eigenvalues') + call dvout (logfil, kplusp, bounds, ndigit, + & '_naup2: Sorted ritz estimates.') + end if +c +c %------------------------------------% +c | Max iterations have been exceeded. | +c %------------------------------------% +c + if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1 +c +c %---------------------% +c | No shifts to apply. | +c %---------------------% +c + if (np .eq. 0 .and. nconv .lt. numcnv) info = 2 +c + np = nconv + go to 1100 +c + else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then +c +c %-------------------------------------------------% +c | Do not have all the requested eigenvalues yet. | +c | To prevent possible stagnation, adjust the size | +c | of NEV. | +c %-------------------------------------------------% +c + nevbef = nev + nev = nev + min(nconv, np/2) + if (nev .eq. 1 .and. kplusp .ge. 6) then + nev = kplusp / 2 + else if (nev .eq. 1 .and. kplusp .gt. 3) then + nev = 2 + end if + np = kplusp - nev +c +c %---------------------------------------% +c | If the size of NEV was just increased | +c | resort the eigenvalues. | +c %---------------------------------------% +c + if (nevbef .lt. nev) + & call dngets (ishift, which, nev, np, ritzr, ritzi, + & bounds, workl, workl(np+1)) +c + end if +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [nconv], ndigit, + & '_naup2: no. of "converged" Ritz values at this iter.') + if (msglvl .gt. 1) then + kp(1) = nev + kp(2) = np + call ivout (logfil, 2, kp, ndigit, + & '_naup2: NEV and NP are') + call dvout (logfil, nev, ritzr(np+1), ndigit, + & '_naup2: "wanted" Ritz values -- real part') + call dvout (logfil, nev, ritzi(np+1), ndigit, + & '_naup2: "wanted" Ritz values -- imag part') + call dvout (logfil, nev, bounds(np+1), ndigit, + & '_naup2: Ritz estimates of the "wanted" values ') + end if + end if +c + if (ishift .eq. 0) then +c +c %-------------------------------------------------------% +c | User specified shifts: reverse comminucation to | +c | compute the shifts. They are returned in the first | +c | 2*NP locations of WORKL. | +c %-------------------------------------------------------% +c + ushift = .true. + ido = 3 + go to 9000 + end if +c + 50 continue +c +c %------------------------------------% +c | Back from reverse communication; | +c | User specified shifts are returned | +c | in WORKL(1:2*NP) | +c %------------------------------------% +c + ushift = .false. +c + if ( ishift .eq. 0 ) then +c +c %----------------------------------% +c | Move the NP shifts from WORKL to | +c | RITZR, RITZI to free up WORKL | +c | for non-exact shift case. | +c %----------------------------------% +c + call dcopy (np, workl, 1, ritzr, 1) + call dcopy (np, workl(np+1), 1, ritzi, 1) + end if +c + if (msglvl .gt. 2) then + call ivout (logfil, 1, [np], ndigit, + & '_naup2: The number of shifts to apply ') + call dvout (logfil, np, ritzr, ndigit, + & '_naup2: Real part of the shifts') + call dvout (logfil, np, ritzi, ndigit, + & '_naup2: Imaginary part of the shifts') + if ( ishift .eq. 1 ) + & call dvout (logfil, np, bounds, ndigit, + & '_naup2: Ritz estimates of the shifts') + end if +c +c %---------------------------------------------------------% +c | Apply the NP implicit shifts by QR bulge chasing. | +c | Each shift is applied to the whole upper Hessenberg | +c | matrix H. | +c | The first 2*N locations of WORKD are used as workspace. | +c %---------------------------------------------------------% +c + call dnapps (n, nev, np, ritzr, ritzi, v, ldv, + & h, ldh, resid, q, ldq, workl, workd) +c +c %---------------------------------------------% +c | Compute the B-norm of the updated residual. | +c | Keep B*RESID in WORKD(1:N) to be used in | +c | the first step of the next call to dnaitr. | +c %---------------------------------------------% +c + cnorm = .true. + call arsecond (t2) + if (bmat .eq. 'G') then + nbx = nbx + 1 + call dcopy (n, resid, 1, workd(n+1), 1) + ipntr(1) = n + 1 + ipntr(2) = 1 + ido = 2 +c +c %----------------------------------% +c | Exit in order to compute B*RESID | +c %----------------------------------% +c + go to 9000 + else if (bmat .eq. 'I') then + call dcopy (n, resid, 1, workd, 1) + end if +c + 100 continue +c +c %----------------------------------% +c | Back from reverse communication; | +c | WORKD(1:N) := B*RESID | +c %----------------------------------% +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c + if (bmat .eq. 'G') then + rnorm = ddot (n, resid, 1, workd, 1) + rnorm = sqrt(abs(rnorm)) + else if (bmat .eq. 'I') then + rnorm = dnrm2(n, resid, 1) + end if + cnorm = .false. +c + if (msglvl .gt. 2) then + call dvout (logfil, 1, [rnorm], ndigit, + & '_naup2: B-norm of residual for compressed factorization') + call dmout (logfil, nev, nev, h, ldh, ndigit, + & '_naup2: Compressed upper Hessenberg matrix H') + end if +c + go to 1000 +c +c %---------------------------------------------------------------% +c | | +c | E N D O F M A I N I T E R A T I O N L O O P | +c | | +c %---------------------------------------------------------------% +c + 1100 continue +c + mxiter = iter + nev = numcnv +c + 1200 continue + ido = 99 +c +c %------------% +c | Error Exit | +c %------------% +c + call arsecond (t1) + tnaup2 = t1 - t0 +c + 9000 continue +c +c %---------------% +c | End of dnaup2 | +c %---------------% +c + return + end diff --git a/src/arpack/dnaupd.f b/src/arpack/dnaupd.f new file mode 100644 index 0000000000..3eb5bc594e --- /dev/null +++ b/src/arpack/dnaupd.f @@ -0,0 +1,693 @@ +c\BeginDoc +c +c\Name: dnaupd +c +c\Description: +c Reverse communication interface for the Implicitly Restarted Arnoldi +c iteration. This subroutine computes approximations to a few eigenpairs +c of a linear operator "OP" with respect to a semi-inner product defined by +c a symmetric positive semi-definite real matrix B. B may be the identity +c matrix. NOTE: If the linear operator "OP" is real and symmetric +c with respect to the real positive semi-definite symmetric matrix B, +c i.e. B*OP = (OP`)*B, then subroutine dsaupd should be used instead. +c +c The computed approximate eigenvalues are called Ritz values and +c the corresponding approximate eigenvectors are called Ritz vectors. +c +c dnaupd is usually called iteratively to solve one of the +c following problems: +c +c Mode 1: A*x = lambda*x. +c ===> OP = A and B = I. +c +c Mode 2: A*x = lambda*M*x, M symmetric positive definite +c ===> OP = inv[M]*A and B = M. +c ===> (If M can be factored see remark 3 below) +c +c Mode 3: A*x = lambda*M*x, M symmetric semi-definite +c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. +c ===> shift-and-invert mode (in real arithmetic) +c If OP*x = amu*x, then +c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. +c Note: If sigma is real, i.e. imaginary part of sigma is zero; +c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M +c amu == 1/(lambda-sigma). +c +c Mode 4: A*x = lambda*M*x, M symmetric semi-definite +c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. +c ===> shift-and-invert mode (in real arithmetic) +c If OP*x = amu*x, then +c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. +c +c Both mode 3 and 4 give the same enhancement to eigenvalues close to +c the (complex) shift sigma. However, as lambda goes to infinity, +c the operator OP in mode 4 dampens the eigenvalues more strongly than +c does OP defined in mode 3. +c +c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v +c should be accomplished either by a direct method +c using a sparse matrix factorization and solving +c +c [A - sigma*M]*w = v or M*w = v, +c +c or through an iterative method for solving these +c systems. If an iterative method is used, the +c convergence test must be more stringent than +c the accuracy requirements for the eigenvalue +c approximations. +c +c\Usage: +c call dnaupd +c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, +c IPNTR, WORKD, WORKL, LWORKL, INFO ) +c +c\Arguments +c IDO Integer. (INPUT/OUTPUT) +c Reverse communication flag. IDO must be zero on the first +c call to dnaupd. IDO will be set internally to +c indicate the type of operation to be performed. Control is +c then given back to the calling routine which has the +c responsibility to carry out the requested operation and call +c dnaupd with the result. The operand is given in +c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). +c ------------------------------------------------------------- +c IDO = 0: first call to the reverse communication interface +c IDO = -1: compute Y = OP * X where +c IPNTR(1) is the pointer into WORKD for X, +c IPNTR(2) is the pointer into WORKD for Y. +c This is for the initialization phase to force the +c starting vector into the range of OP. +c IDO = 1: compute Y = OP * X where +c IPNTR(1) is the pointer into WORKD for X, +c IPNTR(2) is the pointer into WORKD for Y. +c In mode 3 and 4, the vector B * X is already +c available in WORKD(ipntr(3)). It does not +c need to be recomputed in forming OP * X. +c IDO = 2: compute Y = B * X where +c IPNTR(1) is the pointer into WORKD for X, +c IPNTR(2) is the pointer into WORKD for Y. +c IDO = 3: compute the IPARAM(8) real and imaginary parts +c of the shifts where INPTR(14) is the pointer +c into WORKL for placing the shifts. See Remark +c 5 below. +c IDO = 99: done +c ------------------------------------------------------------- +c +c BMAT Character*1. (INPUT) +c BMAT specifies the type of the matrix B that defines the +c semi-inner product for the operator OP. +c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x +c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +c +c N Integer. (INPUT) +c Dimension of the eigenproblem. +c +c WHICH Character*2. (INPUT) +c 'LM' -> want the NEV eigenvalues of largest magnitude. +c 'SM' -> want the NEV eigenvalues of smallest magnitude. +c 'LR' -> want the NEV eigenvalues of largest real part. +c 'SR' -> want the NEV eigenvalues of smallest real part. +c 'LI' -> want the NEV eigenvalues of largest imaginary part. +c 'SI' -> want the NEV eigenvalues of smallest imaginary part. +c +c NEV Integer. (INPUT/OUTPUT) +c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. +c +c TOL Double precision scalar. (INPUT) +c Stopping criterion: the relative accuracy of the Ritz value +c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) +c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. +c DEFAULT = DLAMCH('EPS') (machine precision as computed +c by the LAPACK auxiliary subroutine DLAMCH). +c +c RESID Double precision array of length N. (INPUT/OUTPUT) +c On INPUT: +c If INFO .EQ. 0, a random initial residual vector is used. +c If INFO .NE. 0, RESID contains the initial residual vector, +c possibly from a previous run. +c On OUTPUT: +c RESID contains the final residual vector. +c +c NCV Integer. (INPUT) +c Number of columns of the matrix V. NCV must satisfy the two +c inequalities 2 <= NCV-NEV and NCV <= N. +c This will indicate how many Arnoldi vectors are generated +c at each iteration. After the startup phase in which NEV +c Arnoldi vectors are generated, the algorithm generates +c approximately NCV-NEV Arnoldi vectors at each subsequent update +c iteration. Most of the cost in generating each Arnoldi vector is +c in the matrix-vector operation OP*x. +c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz +c values are kept together. (See remark 4 below) +c +c V Double precision array N by NCV. (OUTPUT) +c Contains the final set of Arnoldi basis vectors. +c +c LDV Integer. (INPUT) +c Leading dimension of V exactly as declared in the calling program. +c +c IPARAM Integer array of length 11. (INPUT/OUTPUT) +c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. +c The shifts selected at each iteration are used to restart +c the Arnoldi iteration in an implicit fashion. +c ------------------------------------------------------------- +c ISHIFT = 0: the shifts are provided by the user via +c reverse communication. The real and imaginary +c parts of the NCV eigenvalues of the Hessenberg +c matrix H are returned in the part of the WORKL +c array corresponding to RITZR and RITZI. See remark +c 5 below. +c ISHIFT = 1: exact shifts with respect to the current +c Hessenberg matrix H. This is equivalent to +c restarting the iteration with a starting vector +c that is a linear combination of approximate Schur +c vectors associated with the "wanted" Ritz values. +c ------------------------------------------------------------- +c +c IPARAM(2) = No longer referenced. +c +c IPARAM(3) = MXITER +c On INPUT: maximum number of Arnoldi update iterations allowed. +c On OUTPUT: actual number of Arnoldi update iterations taken. +c +c IPARAM(4) = NB: blocksize to be used in the recurrence. +c The code currently works only for NB = 1. +c +c IPARAM(5) = NCONV: number of "converged" Ritz values. +c This represents the number of Ritz values that satisfy +c the convergence criterion. +c +c IPARAM(6) = IUPD +c No longer referenced. Implicit restarting is ALWAYS used. +c +c IPARAM(7) = MODE +c On INPUT determines what type of eigenproblem is being solved. +c Must be 1,2,3,4; See under \Description of dnaupd for the +c four modes available. +c +c IPARAM(8) = NP +c When ido = 3 and the user provides shifts through reverse +c communication (IPARAM(1)=0), dnaupd returns NP, the number +c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark +c 5 below. +c +c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, +c OUTPUT: NUMOP = total number of OP*x operations, +c NUMOPB = total number of B*x operations if BMAT='G', +c NUMREO = total number of steps of re-orthogonalization. +c +c IPNTR Integer array of length 14. (OUTPUT) +c Pointer to mark the starting locations in the WORKD and WORKL +c arrays for matrices/vectors used by the Arnoldi iteration. +c ------------------------------------------------------------- +c IPNTR(1): pointer to the current operand vector X in WORKD. +c IPNTR(2): pointer to the current result vector Y in WORKD. +c IPNTR(3): pointer to the vector B * X in WORKD when used in +c the shift-and-invert mode. +c IPNTR(4): pointer to the next available location in WORKL +c that is untouched by the program. +c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix +c H in WORKL. +c IPNTR(6): pointer to the real part of the ritz value array +c RITZR in WORKL. +c IPNTR(7): pointer to the imaginary part of the ritz value array +c RITZI in WORKL. +c IPNTR(8): pointer to the Ritz estimates in array WORKL associated +c with the Ritz values located in RITZR and RITZI in WORKL. +c +c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. +c +c Note: IPNTR(9:13) is only referenced by dneupd. See Remark 2 below. +c +c IPNTR(9): pointer to the real part of the NCV RITZ values of the +c original system. +c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of +c the original system. +c IPNTR(11): pointer to the NCV corresponding error bounds. +c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular +c Schur matrix for H. +c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +c of the upper Hessenberg matrix H. Only referenced by +c dneupd if RVEC = .TRUE. See Remark 2 below. +c ------------------------------------------------------------- +c +c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +c Distributed array to be used in the basic Arnoldi iteration +c for reverse communication. The user should not use WORKD +c as temporary workspace during the iteration. Upon termination +c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace +c associated with the converged Ritz values is desired, see remark +c 2 below, subroutine dneupd uses this output. +c See Data Distribution Note below. +c +c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) +c Private (replicated) array on each PE or array allocated on +c the front end. See Data Distribution Note below. +c +c LWORKL Integer. (INPUT) +c LWORKL must be at least 3*NCV**2 + 6*NCV. +c +c INFO Integer. (INPUT/OUTPUT) +c If INFO .EQ. 0, a randomly initial residual vector is used. +c If INFO .NE. 0, RESID contains the initial residual vector, +c possibly from a previous run. +c Error flag on output. +c = 0: Normal exit. +c = 1: Maximum number of iterations taken. +c All possible eigenvalues of OP has been found. IPARAM(5) +c returns the number of wanted converged Ritz values. +c = 2: No longer an informational error. Deprecated starting +c with release 2 of ARPACK. +c = 3: No shifts could be applied during a cycle of the +c Implicitly restarted Arnoldi iteration. One possibility +c is to increase the size of NCV relative to NEV. +c See remark 4 below. +c = -1: N must be positive. +c = -2: NEV must be positive. +c = -3: NCV-NEV >= 2 and less than or equal to N. +c = -4: The maximum number of Arnoldi update iteration +c must be greater than zero. +c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +c = -6: BMAT must be one of 'I' or 'G'. +c = -7: Length of private work array is not sufficient. +c = -8: Error return from LAPACK eigenvalue calculation; +c = -9: Starting vector is zero. +c = -10: IPARAM(7) must be 1,2,3,4. +c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. +c = -12: IPARAM(1) must be equal to 0 or 1. +c = -9999: Could not build an Arnoldi factorization. +c IPARAM(5) returns the size of the current Arnoldi +c factorization. +c +c\Remarks +c 1. The computed Ritz values are approximate eigenvalues of OP. The +c selection of WHICH should be made with this in mind when +c Mode = 3 and 4. After convergence, approximate eigenvalues of the +c original problem may be obtained with the ARPACK subroutine dneupd. +c +c 2. If a basis for the invariant subspace corresponding to the converged Ritz +c values is needed, the user must call dneupd immediately following +c completion of dnaupd. This is new starting with release 2 of ARPACK. +c +c 3. If M can be factored into a Cholesky factorization M = LL` +c then Mode = 2 should not be selected. Instead one should use +c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular +c linear systems should be solved with L and L` rather +c than computing inverses. After convergence, an approximate +c eigenvector z of the original problem is recovered by solving +c L`z = x where x is a Ritz vector of OP. +c +c 4. At present there is no a-priori analysis to guide the selection +c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2. +c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of +c the same type are to be solved, one should experiment with increasing +c NCV while keeping NEV fixed for a given test problem. This will +c usually decrease the required number of OP*x operations but it +c also increases the work and storage required to maintain the orthogonal +c basis vectors. The optimal "cross-over" with respect to CPU time +c is problem dependent and must be determined empirically. +c See Chapter 8 of Reference 2 for further information. +c +c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the +c NP = IPARAM(8) real and imaginary parts of the shifts in locations +c real part imaginary part +c ----------------------- -------------- +c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP) +c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1) +c . . +c . . +c . . +c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1). +c +c Only complex conjugate pairs of shifts may be applied and the pairs +c must be placed in consecutive locations. The real part of the +c eigenvalues of the current upper Hessenberg matrix are located in +c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part +c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered +c according to the order defined by WHICH. The complex conjugate +c pairs are kept together and the associated Ritz estimates are located in +c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). +c +c----------------------------------------------------------------------- +c +c\Data Distribution Note: +c +c Fortran-D syntax: +c ================ +c Double precision resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +c decompose d1(n), d2(n,ncv) +c align resid(i) with d1(i) +c align v(i,j) with d2(i,j) +c align workd(i) with d1(i) range (1:n) +c align workd(i) with d1(i-n) range (n+1:2*n) +c align workd(i) with d1(i-2*n) range (2*n+1:3*n) +c distribute d1(block), d2(block,:) +c replicated workl(lworkl) +c +c Cray MPP syntax: +c =============== +c Double precision resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) +c shared resid(block), v(block,:), workd(block,:) +c replicated workl(lworkl) +c +c CM2/CM5 syntax: +c ============== +c +c----------------------------------------------------------------------- +c +c include 'ex-nonsym.doc' +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +c Restarted Arnoldi Iteration", Rice University Technical Report +c TR95-13, Department of Computational and Applied Mathematics. +c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for +c Real Matrices", Linear Algebra and its Applications, vol 88/89, +c pp 575-595, (1987). +c +c\Routines called: +c dnaup2 ARPACK routine that implements the Implicitly Restarted +c Arnoldi Iteration. +c ivout ARPACK utility routine that prints integers. +c second ARPACK utility routine for timing. +c dvout ARPACK utility routine that prints vectors. +c dlamch LAPACK routine that determines machine constants. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c 12/16/93: Version '1.1' +c +c\SCCS Information: @(#) +c FILE: naupd.F SID: 2.10 DATE OF SID: 08/23/02 RELEASE: 2 +c +c\Remarks +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dnaupd + & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, + & ipntr, workd, workl, lworkl, info ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character bmat*1, which*2 + integer ido, info, ldv, lworkl, n, ncv, nev + Double precision + & tol +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + integer iparam(11), ipntr(14) + Double precision + & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer bounds, ierr, ih, iq, ishift, iupd, iw, + & ldh, ldq, levec, mode, msglvl, mxiter, nb, + & nev0, next, np, ritzi, ritzr, j + save bounds, ih, iq, ishift, iupd, iw, ldh, ldq, + & levec, mode, msglvl, mxiter, nb, nev0, next, + & np, ritzi, ritzr +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dnaup2, dvout, ivout, second, dstatn +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dlamch + external dlamch +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + if (ido .eq. 0) then +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call dstatn + call arsecond (t0) + msglvl = mnaupd +c +c %----------------% +c | Error checking | +c %----------------% +c + ierr = 0 + ishift = iparam(1) +c levec = iparam(2) + mxiter = iparam(3) +c nb = iparam(4) + nb = 1 +c +c %--------------------------------------------% +c | Revision 2 performs only implicit restart. | +c %--------------------------------------------% +c + iupd = 1 + mode = iparam(7) +c + if (n .le. 0) then + ierr = -1 + else if (nev .le. 0) then + ierr = -2 + else if (ncv .le. nev+1 .or. ncv .gt. n) then + ierr = -3 + else if (mxiter .le. 0) then + ierr = 4 + else if (which .ne. 'LM' .and. + & which .ne. 'SM' .and. + & which .ne. 'LR' .and. + & which .ne. 'SR' .and. + & which .ne. 'LI' .and. + & which .ne. 'SI') then + ierr = -5 + else if (bmat .ne. 'I' .and. bmat .ne. 'G') then + ierr = -6 + else if (lworkl .lt. 3*ncv**2 + 6*ncv) then + ierr = -7 + else if (mode .lt. 1 .or. mode .gt. 4) then + ierr = -10 + else if (mode .eq. 1 .and. bmat .eq. 'G') then + ierr = -11 + else if (ishift .lt. 0 .or. ishift .gt. 1) then + ierr = -12 + end if +c +c %------------% +c | Error Exit | +c %------------% +c + if (ierr .ne. 0) then + info = ierr + ido = 99 + go to 9000 + end if +c +c %------------------------% +c | Set default parameters | +c %------------------------% +c + if (nb .le. 0) nb = 1 + if (tol .le. zero) tol = dlamch('EpsMach') +c +c %----------------------------------------------% +c | NP is the number of additional steps to | +c | extend the length NEV Lanczos factorization. | +c | NEV0 is the local variable designating the | +c | size of the invariant subspace desired. | +c %----------------------------------------------% +c + np = ncv - nev + nev0 = nev +c +c %-----------------------------% +c | Zero out internal workspace | +c %-----------------------------% +c + do 10 j = 1, 3*ncv**2 + 6*ncv + workl(j) = zero + 10 continue +c +c %-------------------------------------------------------------% +c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +c | etc... and the remaining workspace. | +c | Also update pointer to be used on output. | +c | Memory is laid out as follows: | +c | workl(1:ncv*ncv) := generated Hessenberg matrix | +c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | +c | parts of ritz values | +c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | +c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | +c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | +c | The final workspace is needed by subroutine dneigh called | +c | by dnaup2. Subroutine dneigh calls LAPACK routines for | +c | calculating eigenvalues and the last row of the eigenvector | +c | matrix. | +c %-------------------------------------------------------------% +c + ldh = ncv + ldq = ncv + ih = 1 + ritzr = ih + ldh*ncv + ritzi = ritzr + ncv + bounds = ritzi + ncv + iq = bounds + ncv + iw = iq + ldq*ncv + next = iw + ncv**2 + 3*ncv +c + ipntr(4) = next + ipntr(5) = ih + ipntr(6) = ritzr + ipntr(7) = ritzi + ipntr(8) = bounds + ipntr(14) = iw +c + end if +c +c %-------------------------------------------------------% +c | Carry out the Implicitly restarted Arnoldi Iteration. | +c %-------------------------------------------------------% +c + call dnaup2 + & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, + & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr), + & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw), + & ipntr, workd, info ) +c +c %--------------------------------------------------% +c | ido .ne. 99 implies use of reverse communication | +c | to compute operations involving OP or shifts. | +c %--------------------------------------------------% +c + if (ido .eq. 3) iparam(8) = np + if (ido .ne. 99) go to 9000 +c + iparam(3) = mxiter + iparam(5) = np + iparam(9) = nopx + iparam(10) = nbx + iparam(11) = nrorth +c +c %------------------------------------% +c | Exit if there was an informational | +c | error within dnaup2. | +c %------------------------------------% +c + if (info .lt. 0) go to 9000 + if (info .eq. 2) info = 3 +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [mxiter], ndigit, + & '_naupd: Number of update iterations taken') + call ivout (logfil, 1, [np], ndigit, + & '_naupd: Number of wanted "converged" Ritz values') + call dvout (logfil, np, workl(ritzr), ndigit, + & '_naupd: Real part of the final Ritz values') + call dvout (logfil, np, workl(ritzi), ndigit, + & '_naupd: Imaginary part of the final Ritz values') + call dvout (logfil, np, workl(bounds), ndigit, + & '_naupd: Associated Ritz estimates') + end if +c + call arsecond (t1) + tnaupd = t1 - t0 +c + if (msglvl .gt. 0) then +c +c %--------------------------------------------------------% +c | Version Number & Version Date are defined in version.h | +c %--------------------------------------------------------% +c + write (6,1000) + write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, + & tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref, + & tgetv0, tneigh, tngets, tnapps, tnconv, trvec + 1000 format (//, + & 5x, '=============================================',/ + & 5x, '= Nonsymmetric implicit Arnoldi update code =',/ + & 5x, '= Version Number: ', ' 2.4', 21x, ' =',/ + & 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/ + & 5x, '=============================================',/ + & 5x, '= Summary of timing statistics =',/ + & 5x, '=============================================',//) + 1100 format ( + & 5x, 'Total number update iterations = ', i5,/ + & 5x, 'Total number of OP*x operations = ', i5,/ + & 5x, 'Total number of B*x operations = ', i5,/ + & 5x, 'Total number of reorthogonalization steps = ', i5,/ + & 5x, 'Total number of iterative refinement steps = ', i5,/ + & 5x, 'Total number of restart steps = ', i5,/ + & 5x, 'Total time in user OP*x operation = ', f12.6,/ + & 5x, 'Total time in user B*x operation = ', f12.6,/ + & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ + & 5x, 'Total time in naup2 routine = ', f12.6,/ + & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ + & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ + & 5x, 'Total time in (re)start vector generation = ', f12.6,/ + & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ + & 5x, 'Total time in getting the shifts = ', f12.6,/ + & 5x, 'Total time in applying the shifts = ', f12.6,/ + & 5x, 'Total time in convergence testing = ', f12.6,/ + & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) + end if +c + 9000 continue +c + return +c +c %---------------% +c | End of dnaupd | +c %---------------% +c + end diff --git a/src/arpack/dnaupe.f b/src/arpack/dnaupe.f new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/arpack/dnconv.f b/src/arpack/dnconv.f new file mode 100644 index 0000000000..7ca0d16353 --- /dev/null +++ b/src/arpack/dnconv.f @@ -0,0 +1,146 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dnconv +c +c\Description: +c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine. +c +c\Usage: +c call dnconv +c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV ) +c +c\Arguments +c N Integer. (INPUT) +c Number of Ritz values to check for convergence. +c +c RITZR, Double precision arrays of length N. (INPUT) +c RITZI Real and imaginary parts of the Ritz values to be checked +c for convergence. + +c BOUNDS Double precision array of length N. (INPUT) +c Ritz estimates for the Ritz values in RITZR and RITZI. +c +c TOL Double precision scalar. (INPUT) +c Desired backward error for a Ritz value to be considered +c "converged". +c +c NCONV Integer scalar. (OUTPUT) +c Number of "converged" Ritz values. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\Routines called: +c second ARPACK utility routine for timing. +c dlamch LAPACK routine that determines machine constants. +c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/92: Version ' 2.1' +c +c\SCCS Information: @(#) +c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +c +c\Remarks +c 1. xxxx +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dnconv (n, ritzr, ritzi, bounds, tol, nconv) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + integer n, nconv + Double precision + & tol +c +c %-----------------% +c | Array Arguments | +c %-----------------% + + Double precision + & ritzr(n), ritzi(n), bounds(n) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer i + Double precision + & temp, eps23 +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dlapy2, dlamch + external dlapy2, dlamch + +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c +c %-------------------------------------------------------------% +c | Convergence test: unlike in the symmetric code, I am not | +c | using things like refined error bounds and gap condition | +c | because I don't know the exact equivalent concept. | +c | | +c | Instead the i-th Ritz value is considered "converged" when: | +c | | +c | bounds(i) .le. ( TOL * | ritz | ) | +c | | +c | for some appropriate choice of norm. | +c %-------------------------------------------------------------% +c + call arsecond (t0) +c +c %---------------------------------% +c | Get machine dependent constant. | +c %---------------------------------% +c + eps23 = dlamch('Epsilon-Machine') + eps23 = eps23**(2.0D+0 / 3.0D+0) +c + nconv = 0 + do 20 i = 1, n + temp = max( eps23, dlapy2( ritzr(i), ritzi(i) ) ) + if (bounds(i) .le. tol*temp) nconv = nconv + 1 + 20 continue +c + call arsecond (t1) + tnconv = tnconv + (t1 - t0) +c + return +c +c %---------------% +c | End of dnconv | +c %---------------% +c + end diff --git a/src/arpack/dneigh.f b/src/arpack/dneigh.f new file mode 100644 index 0000000000..6c1884c5b9 --- /dev/null +++ b/src/arpack/dneigh.f @@ -0,0 +1,314 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dneigh +c +c\Description: +c Compute the eigenvalues of the current upper Hessenberg matrix +c and the corresponding Ritz estimates given the current residual norm. +c +c\Usage: +c call dneigh +c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR ) +c +c\Arguments +c RNORM Double precision scalar. (INPUT) +c Residual norm corresponding to the current upper Hessenberg +c matrix H. +c +c N Integer. (INPUT) +c Size of the matrix H. +c +c H Double precision N by N array. (INPUT) +c H contains the current upper Hessenberg matrix. +c +c LDH Integer. (INPUT) +c Leading dimension of H exactly as declared in the calling +c program. +c +c RITZR, Double precision arrays of length N. (OUTPUT) +c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real +c (respectively imaginary) parts of the eigenvalues of H. +c +c BOUNDS Double precision array of length N. (OUTPUT) +c On output, BOUNDS contains the Ritz estimates associated with +c the eigenvalues RITZR and RITZI. This is equal to RNORM +c times the last components of the eigenvectors corresponding +c to the eigenvalues in RITZR and RITZI. +c +c Q Double precision N by N array. (WORKSPACE) +c Workspace needed to store the eigenvectors of H. +c +c LDQ Integer. (INPUT) +c Leading dimension of Q exactly as declared in the calling +c program. +c +c WORKL Double precision work array of length N**2 + 3*N. (WORKSPACE) +c Private (replicated) array on each PE or array allocated on +c the front end. This is needed to keep the full Schur form +c of H and also in the calculation of the eigenvectors of H. +c +c IERR Integer. (OUTPUT) +c Error exit flag from dlaqrb or dtrevc. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\Routines called: +c dlaqrb ARPACK routine to compute the real Schur form of an +c upper Hessenberg matrix and last row of the Schur vectors. +c second ARPACK utility routine for timing. +c dmout ARPACK utility routine that prints matrices +c dvout ARPACK utility routine that prints vectors. +c dlacpy LAPACK matrix copy routine. +c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +c dtrevc LAPACK routine to compute the eigenvectors of a matrix +c in upper quasi-triangular form +c dgemv Level 2 BLAS routine for matrix vector multiplication. +c dcopy Level 1 BLAS that copies one vector to another . +c dnrm2 Level 1 BLAS that computes the norm of a vector. +c dscal Level 1 BLAS that scales a vector. +c +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/92: Version ' 2.1' +c +c\SCCS Information: @(#) +c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +c +c\Remarks +c None +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds, + & q, ldq, workl, ierr) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + integer ierr, n, ldh, ldq + Double precision + & rnorm +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n), + & workl(n*(n+3)) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %------------------------% +c | Local Scalars & Arrays | +c %------------------------% +c + logical select(1) + integer i, iconj, msglvl + Double precision + & temp, vl(1) +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dcopy, dlacpy, dlaqrb, dtrevc, dvout, second +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dlapy2, dnrm2 + external dlapy2, dnrm2 +c +c %---------------------% +c | Intrinsic Functions | +c %---------------------% +c + intrinsic abs +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = mneigh +c + if (msglvl .gt. 2) then + call dmout (logfil, n, n, h, ldh, ndigit, + & '_neigh: Entering upper Hessenberg matrix H ') + end if +c +c %-----------------------------------------------------------% +c | 1. Compute the eigenvalues, the last components of the | +c | corresponding Schur vectors and the full Schur form T | +c | of the current upper Hessenberg matrix H. | +c | dlaqrb returns the full Schur form of H in WORKL(1:N**2) | +c | and the last components of the Schur vectors in BOUNDS. | +c %-----------------------------------------------------------% +c + call dlacpy ('All', n, n, h, ldh, workl, n) + call dlaqrb (.true., n, 1, n, workl, n, ritzr, ritzi, bounds, + & ierr) + if (ierr .ne. 0) go to 9000 +c + if (msglvl .gt. 1) then + call dvout (logfil, n, bounds, ndigit, + & '_neigh: last row of the Schur matrix for H') + end if +c +c %-----------------------------------------------------------% +c | 2. Compute the eigenvectors of the full Schur form T and | +c | apply the last components of the Schur vectors to get | +c | the last components of the corresponding eigenvectors. | +c | Remember that if the i-th and (i+1)-st eigenvalues are | +c | complex conjugate pairs, then the real & imaginary part | +c | of the eigenvector components are split across adjacent | +c | columns of Q. | +c %-----------------------------------------------------------% +c + call dtrevc ('R', 'A', select, n, workl, n, vl, n, q, ldq, + & n, n, workl(n*n+1), ierr) +c + if (ierr .ne. 0) go to 9000 +c +c %------------------------------------------------% +c | Scale the returning eigenvectors so that their | +c | euclidean norms are all one. LAPACK subroutine | +c | dtrevc returns each eigenvector normalized so | +c | that the element of largest magnitude has | +c | magnitude 1; here the magnitude of a complex | +c | number (x,y) is taken to be |x| + |y|. | +c %------------------------------------------------% +c + iconj = 0 + do 10 i=1, n + if ( abs( ritzi(i) ) .le. zero ) then +c +c %----------------------% +c | Real eigenvalue case | +c %----------------------% +c + temp = dnrm2( n, q(1,i), 1 ) + call dscal ( n, one / temp, q(1,i), 1 ) + else +c +c %-------------------------------------------% +c | Complex conjugate pair case. Note that | +c | since the real and imaginary part of | +c | the eigenvector are stored in consecutive | +c | columns, we further normalize by the | +c | square root of two. | +c %-------------------------------------------% +c + if (iconj .eq. 0) then + temp = dlapy2( dnrm2( n, q(1,i), 1 ), + & dnrm2( n, q(1,i+1), 1 ) ) + call dscal ( n, one / temp, q(1,i), 1 ) + call dscal ( n, one / temp, q(1,i+1), 1 ) + iconj = 1 + else + iconj = 0 + end if + end if + 10 continue +c + call dgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1) +c + if (msglvl .gt. 1) then + call dvout (logfil, n, workl, ndigit, + & '_neigh: Last row of the eigenvector matrix for H') + end if +c +c %----------------------------% +c | Compute the Ritz estimates | +c %----------------------------% +c + iconj = 0 + do 20 i = 1, n + if ( abs( ritzi(i) ) .le. zero ) then +c +c %----------------------% +c | Real eigenvalue case | +c %----------------------% +c + bounds(i) = rnorm * abs( workl(i) ) + else +c +c %-------------------------------------------% +c | Complex conjugate pair case. Note that | +c | since the real and imaginary part of | +c | the eigenvector are stored in consecutive | +c | columns, we need to take the magnitude | +c | of the last components of the two vectors | +c %-------------------------------------------% +c + if (iconj .eq. 0) then + bounds(i) = rnorm * dlapy2( workl(i), workl(i+1) ) + bounds(i+1) = bounds(i) + iconj = 1 + else + iconj = 0 + end if + end if + 20 continue +c + if (msglvl .gt. 2) then + call dvout (logfil, n, ritzr, ndigit, + & '_neigh: Real part of the eigenvalues of H') + call dvout (logfil, n, ritzi, ndigit, + & '_neigh: Imaginary part of the eigenvalues of H') + call dvout (logfil, n, bounds, ndigit, + & '_neigh: Ritz estimates for the eigenvalues of H') + end if +c + call arsecond (t1) + tneigh = tneigh + (t1 - t0) +c + 9000 continue + return +c +c %---------------% +c | End of dneigh | +c %---------------% +c + end diff --git a/src/arpack/dneupd.f b/src/arpack/dneupd.f new file mode 100644 index 0000000000..82cc5ffcfc --- /dev/null +++ b/src/arpack/dneupd.f @@ -0,0 +1,1063 @@ +c\BeginDoc +c +c\Name: dneupd +c +c\Description: +c +c This subroutine returns the converged approximations to eigenvalues +c of A*z = lambda*B*z and (optionally): +c +c (1) The corresponding approximate eigenvectors; +c +c (2) An orthonormal basis for the associated approximate +c invariant subspace; +c +c (3) Both. +c +c There is negligible additional cost to obtain eigenvectors. An orthonormal +c basis is always computed. There is an additional storage cost of n*nev +c if both are requested (in this case a separate array Z must be supplied). +c +c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z +c are derived from approximate eigenvalues and eigenvectors of +c of the linear operator OP prescribed by the MODE selection in the +c call to DNAUPD . DNAUPD must be called before this routine is called. +c These approximate eigenvalues and vectors are commonly called Ritz +c values and Ritz vectors respectively. They are referred to as such +c in the comments that follow. The computed orthonormal basis for the +c invariant subspace corresponding to these Ritz values is referred to as a +c Schur basis. +c +c See documentation in the header of the subroutine DNAUPD for +c definition of OP as well as other terms and the relation of computed +c Ritz values and Ritz vectors of OP with respect to the given problem +c A*z = lambda*B*z. For a brief description, see definitions of +c IPARAM(7), MODE and WHICH in the documentation of DNAUPD . +c +c\Usage: +c call dneupd +c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT, +c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, +c LWORKL, INFO ) +c +c\Arguments: +c RVEC LOGICAL (INPUT) +c Specifies whether a basis for the invariant subspace corresponding +c to the converged Ritz value approximations for the eigenproblem +c A*z = lambda*B*z is computed. +c +c RVEC = .FALSE. Compute Ritz values only. +c +c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. +c See Remarks below. +c +c HOWMNY Character*1 (INPUT) +c Specifies the form of the basis for the invariant subspace +c corresponding to the converged Ritz values that is to be computed. +c +c = 'A': Compute NEV Ritz vectors; +c = 'P': Compute NEV Schur vectors; +c = 'S': compute some of the Ritz vectors, specified +c by the logical array SELECT. +c +c SELECT Logical array of dimension NCV. (INPUT) +c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be +c computed. To select the Ritz vector corresponding to a +c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. +c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. +c +c DR Double precision array of dimension NEV+1. (OUTPUT) +c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains +c the real part of the Ritz approximations to the eigenvalues of +c A*z = lambda*B*z. +c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit: +c DR contains the real part of the Ritz values of OP computed by +c DNAUPD . A further computation must be performed by the user +c to transform the Ritz values computed for OP by DNAUPD to those +c of the original system A*z = lambda*B*z. See remark 3 below. +c +c DI Double precision array of dimension NEV+1. (OUTPUT) +c On exit, DI contains the imaginary part of the Ritz value +c approximations to the eigenvalues of A*z = lambda*B*z associated +c with DR. +c +c NOTE: When Ritz values are complex, they will come in complex +c conjugate pairs. If eigenvectors are requested, the +c corresponding Ritz vectors will also come in conjugate +c pairs and the real and imaginary parts of these are +c represented in two consecutive columns of the array Z +c (see below). +c +c Z Double precision N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) +c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of +c Z represent approximate eigenvectors (Ritz vectors) corresponding +c to the NCONV=IPARAM(5) Ritz values for eigensystem +c A*z = lambda*B*z. +c +c The complex Ritz vector associated with the Ritz value +c with positive imaginary part is stored in two consecutive +c columns. The first column holds the real part of the Ritz +c vector and the second column holds the imaginary part. The +c Ritz vector associated with the Ritz value with negative +c imaginary part is simply the complex conjugate of the Ritz vector +c associated with the positive imaginary part. +c +c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. +c +c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, +c the array Z may be set equal to first NEV+1 columns of the Arnoldi +c basis array V computed by DNAUPD . In this case the Arnoldi basis +c will be destroyed and overwritten with the eigenvector basis. +c +c LDZ Integer. (INPUT) +c The leading dimension of the array Z. If Ritz vectors are +c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. +c +c SIGMAR Double precision (INPUT) +c If IPARAM(7) = 3 or 4, represents the real part of the shift. +c Not referenced if IPARAM(7) = 1 or 2. +c +c SIGMAI Double precision (INPUT) +c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift. +c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below. +c +c WORKEV Double precision work array of dimension 3*NCV. (WORKSPACE) +c +c **** The remaining arguments MUST be the same as for the **** +c **** call to DNAUPD that was just completed. **** +c +c NOTE: The remaining arguments +c +c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, +c WORKD, WORKL, LWORKL, INFO +c +c must be passed directly to DNEUPD following the last call +c to DNAUPD . These arguments MUST NOT BE MODIFIED between +c the the last call to DNAUPD and the call to DNEUPD . +c +c Three of these parameters (V, WORKL, INFO) are also output parameters: +c +c V Double precision N by NCV array. (INPUT/OUTPUT) +c +c Upon INPUT: the NCV columns of V contain the Arnoldi basis +c vectors for OP as constructed by DNAUPD . +c +c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns +c contain approximate Schur vectors that span the +c desired invariant subspace. See Remark 2 below. +c +c NOTE: If the array Z has been set equal to first NEV+1 columns +c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the +c Arnoldi basis held by V has been overwritten by the desired +c Ritz vectors. If a separate array Z has been passed then +c the first NCONV=IPARAM(5) columns of V will contain approximate +c Schur vectors that span the desired invariant subspace. +c +c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) +c WORKL(1:ncv*ncv+3*ncv) contains information obtained in +c dnaupd . They are not changed by dneupd . +c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the +c real and imaginary part of the untransformed Ritz values, +c the upper quasi-triangular matrix for H, and the +c associated matrix representation of the invariant subspace for H. +c +c Note: IPNTR(9:13) contains the pointer into WORKL for addresses +c of the above information computed by dneupd . +c ------------------------------------------------------------- +c IPNTR(9): pointer to the real part of the NCV RITZ values of the +c original system. +c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of +c the original system. +c IPNTR(11): pointer to the NCV corresponding error bounds. +c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular +c Schur matrix for H. +c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +c of the upper Hessenberg matrix H. Only referenced by +c dneupd if RVEC = .TRUE. See Remark 2 below. +c ------------------------------------------------------------- +c +c INFO Integer. (OUTPUT) +c Error flag on output. +c +c = 0: Normal exit. +c +c = 1: The Schur form computed by LAPACK routine dlahqr +c could not be reordered by LAPACK routine dtrsen . +c Re-enter subroutine dneupd with IPARAM(5)=NCV and +c increase the size of the arrays DR and DI to have +c dimension at least dimension NCV and allocate at least NCV +c columns for Z. NOTE: Not necessary if Z and V share +c the same space. Please notify the authors if this error +c occurs. +c +c = -1: N must be positive. +c = -2: NEV must be positive. +c = -3: NCV-NEV >= 2 and less than or equal to N. +c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +c = -6: BMAT must be one of 'I' or 'G'. +c = -7: Length of private work WORKL array is not sufficient. +c = -8: Error return from calculation of a real Schur form. +c Informational error from LAPACK routine dlahqr . +c = -9: Error return from calculation of eigenvectors. +c Informational error from LAPACK routine dtrevc . +c = -10: IPARAM(7) must be 1,2,3,4. +c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +c = -12: HOWMNY = 'S' not yet implemented +c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. +c = -14: DNAUPD did not find any eigenvalues to sufficient +c accuracy. +c = -15: DNEUPD got a different count of the number of converged +c Ritz values than DNAUPD got. This indicates the user +c probably made an error in passing data from DNAUPD to +c DNEUPD or that the data was modified before entering +c DNEUPD +c +c\BeginLib +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +c Restarted Arnoldi Iteration", Rice University Technical Report +c TR95-13, Department of Computational and Applied Mathematics. +c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for +c Real Matrices", Linear Algebra and its Applications, vol 88/89, +c pp 575-595, (1987). +c +c\Routines called: +c ivout ARPACK utility routine that prints integers. +c dmout ARPACK utility routine that prints matrices +c dvout ARPACK utility routine that prints vectors. +c dgeqr2 LAPACK routine that computes the QR factorization of +c a matrix. +c dlacpy LAPACK matrix copy routine. +c dlahqr LAPACK routine to compute the real Schur form of an +c upper Hessenberg matrix. +c dlamch LAPACK routine that determines machine constants. +c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +c dlaset LAPACK matrix initialization routine. +c dorm2r LAPACK routine that applies an orthogonal matrix in +c factored form. +c dtrevc LAPACK routine to compute the eigenvectors of a matrix +c in upper quasi-triangular form. +c dtrsen LAPACK routine that re-orders the Schur form. +c dtrmm Level 3 BLAS matrix times an upper triangular matrix. +c dger Level 2 BLAS rank one update to a matrix. +c dcopy Level 1 BLAS that copies one vector to another . +c ddot Level 1 BLAS that computes the scalar product of two vectors. +c dnrm2 Level 1 BLAS that computes the norm of a vector. +c dscal Level 1 BLAS that scales a vector. +c +c\Remarks +c +c 1. Currently only HOWMNY = 'A' and 'P' are implemented. +c +c Let trans(X) denote the transpose of X. +c +c 2. Schur vectors are an orthogonal representation for the basis of +c Ritz vectors. Thus, their numerical properties are often superior. +c If RVEC = .TRUE. then the relationship +c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and +c trans(V(:,1:IPARAM(5))) * V(:,1:IPARAM(5)) = I are approximately +c satisfied. Here T is the leading submatrix of order IPARAM(5) of the +c real upper quasi-triangular matrix stored workl(ipntr(12)). That is, +c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; +c each 2-by-2 diagonal block has its diagonal elements equal and its +c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 +c diagonal block is a complex conjugate pair of Ritz values. The real +c Ritz values are stored on the diagonal of T. +c +c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must +c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz +c values computed by DNAUPD for OP to those of A*z = lambda*B*z. +c Set RVEC = .true. and HOWMNY = 'A', and +c compute +c trans(Z(:,I)) * A * Z(:,I) if DI(I) = 0. +c If DI(I) is not equal to zero and DI(I+1) = - D(I), +c then the desired real and imaginary parts of the Ritz value are +c trans(Z(:,I)) * A * Z(:,I) + trans(Z(:,I+1)) * A * Z(:,I+1), +c trans(Z(:,I)) * A * Z(:,I+1) - trans(Z(:,I+1)) * A * Z(:,I), +c respectively. +c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and +c compute trans(V(:,1:IPARAM(5))) * A * V(:,1:IPARAM(5)) and then an upper +c quasi-triangular matrix of order IPARAM(5) is computed. See remark +c 2 above. +c +c\Authors +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Chao Yang Houston, Texas +c Dept. of Computational & +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\SCCS Information: @(#) +c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 +c +c\EndLib +c +c----------------------------------------------------------------------- + subroutine dneupd (rvec , howmny, select, dr , di, + & z , ldz , sigmar, sigmai, workev, + & bmat , n , which , nev , tol, + & resid, ncv , v , ldv , iparam, + & ipntr, workd , workl , lworkl, info) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character bmat, howmny, which*2 + logical rvec + integer info, ldz, ldv, lworkl, n, ncv, nev + Double precision + & sigmar, sigmai, tol +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + integer iparam(11), ipntr(14) + logical select(ncv) + Double precision + & dr(nev+1) , di(nev+1), resid(n) , + & v(ldv,ncv) , z(ldz,*) , workd(3*n), + & workl(lworkl), workev(3*ncv) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0 , zero = 0.0D+0 ) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + character type*6 + integer bounds, ierr , ih , ihbds , + & iheigr, iheigi, iconj , nconv , + & invsub, iuptri, iwev , iwork(1), + & j , k , ldh , ldq , + & mode , msglvl, outncv, ritzr , + & ritzi , wri , wrr , irr , + & iri , ibd , ishift, numcnv , + & np , jj + logical reord + Double precision + & conds , rnorm, sep , temp, + & vl(1,1), temp1, eps23 +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dcopy , dger , dgeqr2 , dlacpy , + & dlahqr , dlaset , dmout , dorm2r , + & dtrevc , dtrmm , dtrsen , dscal , + & dvout , ivout +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dlapy2 , dnrm2 , dlamch , ddot + external dlapy2 , dnrm2 , dlamch , ddot +c +c %---------------------% +c | Intrinsic Functions | +c %---------------------% +c + intrinsic abs, min, sqrt +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c +c %------------------------% +c | Set default parameters | +c %------------------------% +c + msglvl = mneupd + mode = iparam(7) + nconv = iparam(5) + info = 0 +c +c %---------------------------------% +c | Get machine dependent constant. | +c %---------------------------------% +c + eps23 = dlamch ('Epsilon-Machine') + eps23 = eps23**(2.0D+0 / 3.0D+0 ) +c +c %--------------% +c | Quick return | +c %--------------% +c + ierr = 0 +c + if (nconv .le. 0) then + ierr = -14 + else if (n .le. 0) then + ierr = -1 + else if (nev .le. 0) then + ierr = -2 + else if (ncv .le. nev+1 .or. ncv .gt. n) then + ierr = -3 + else if (which .ne. 'LM' .and. + & which .ne. 'SM' .and. + & which .ne. 'LR' .and. + & which .ne. 'SR' .and. + & which .ne. 'LI' .and. + & which .ne. 'SI') then + ierr = -5 + else if (bmat .ne. 'I' .and. bmat .ne. 'G') then + ierr = -6 + else if (lworkl .lt. 3*ncv**2 + 6*ncv) then + ierr = -7 + else if ( (howmny .ne. 'A' .and. + & howmny .ne. 'P' .and. + & howmny .ne. 'S') .and. rvec ) then + ierr = -13 + else if (howmny .eq. 'S' ) then + ierr = -12 + end if +c + if (mode .eq. 1 .or. mode .eq. 2) then + type = 'REGULR' + else if (mode .eq. 3 .and. sigmai .eq. zero) then + type = 'SHIFTI' + else if (mode .eq. 3 ) then + type = 'REALPT' + else if (mode .eq. 4 ) then + type = 'IMAGPT' + else + ierr = -10 + end if + if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 +c +c %------------% +c | Error Exit | +c %------------% +c + if (ierr .ne. 0) then + info = ierr + go to 9000 + end if +c +c %--------------------------------------------------------% +c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +c | etc... and the remaining workspace. | +c | Also update pointer to be used on output. | +c | Memory is laid out as follows: | +c | workl(1:ncv*ncv) := generated Hessenberg matrix | +c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | +c | parts of ritz values | +c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | +c %--------------------------------------------------------% +c +c %-----------------------------------------------------------% +c | The following is used and set by DNEUPD . | +c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | +c | real part of the Ritz values. | +c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | +c | imaginary part of the Ritz values. | +c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | +c | error bounds of the Ritz values | +c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | +c | quasi-triangular matrix for H | +c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | +c | associated matrix representation of the invariant | +c | subspace for H. | +c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | +c %-----------------------------------------------------------% +c + ih = ipntr(5) + ritzr = ipntr(6) + ritzi = ipntr(7) + bounds = ipntr(8) + ldh = ncv + ldq = ncv + iheigr = bounds + ldh + iheigi = iheigr + ldh + ihbds = iheigi + ldh + iuptri = ihbds + ldh + invsub = iuptri + ldh*ncv + ipntr(9) = iheigr + ipntr(10) = iheigi + ipntr(11) = ihbds + ipntr(12) = iuptri + ipntr(13) = invsub + wrr = 1 + wri = ncv + 1 + iwev = wri + ncv +c +c %-----------------------------------------% +c | irr points to the REAL part of the Ritz | +c | values computed by _neigh before | +c | exiting _naup2. | +c | iri points to the IMAGINARY part of the | +c | Ritz values computed by _neigh | +c | before exiting _naup2. | +c | ibd points to the Ritz estimates | +c | computed by _neigh before exiting | +c | _naup2. | +c %-----------------------------------------% +c + irr = ipntr(14)+ncv*ncv + iri = irr+ncv + ibd = iri+ncv +c +c %------------------------------------% +c | RNORM is B-norm of the RESID(1:N). | +c %------------------------------------% +c + rnorm = workl(ih+2) + workl(ih+2) = zero +c + if (msglvl .gt. 2) then + call dvout (logfil, ncv, workl(irr), ndigit, + & '_neupd: Real part of Ritz values passed in from _NAUPD.') + call dvout (logfil, ncv, workl(iri), ndigit, + & '_neupd: Imag part of Ritz values passed in from _NAUPD.') + call dvout (logfil, ncv, workl(ibd), ndigit, + & '_neupd: Ritz estimates passed in from _NAUPD.') + end if +c + if (rvec) then +c + reord = .false. +c +c %---------------------------------------------------% +c | Use the temporary bounds array to store indices | +c | These will be used to mark the select array later | +c %---------------------------------------------------% +c + do 10 j = 1,ncv + workl(bounds+j-1) = j + select(j) = .false. + 10 continue +c +c %-------------------------------------% +c | Select the wanted Ritz values. | +c | Sort the Ritz values so that the | +c | wanted ones appear at the tailing | +c | NEV positions of workl(irr) and | +c | workl(iri). Move the corresponding | +c | error estimates in workl(bound) | +c | accordingly. | +c %-------------------------------------% +c + np = ncv - nev + ishift = 0 + call dngets (ishift , which , nev , + & np , workl(irr), workl(iri), + & workl(bounds), workl , workl(np+1)) +c + if (msglvl .gt. 2) then + call dvout (logfil, ncv, workl(irr), ndigit, + & '_neupd: Real part of Ritz values after calling _NGETS.') + call dvout (logfil, ncv, workl(iri), ndigit, + & '_neupd: Imag part of Ritz values after calling _NGETS.') + call dvout (logfil, ncv, workl(bounds), ndigit, + & '_neupd: Ritz value indices after calling _NGETS.') + end if +c +c %-----------------------------------------------------% +c | Record indices of the converged wanted Ritz values | +c | Mark the select array for possible reordering | +c %-----------------------------------------------------% +c + numcnv = 0 + do 11 j = 1,ncv + temp1 = max(eps23, + & dlapy2 ( workl(irr+ncv-j), workl(iri+ncv-j) )) + jj = workl(bounds + ncv - j) + if (numcnv .lt. nconv .and. + & workl(ibd+jj-1) .le. tol*temp1) then + select(jj) = .true. + numcnv = numcnv + 1 + if (jj .gt. nev) reord = .true. + endif + 11 continue +c +c %-----------------------------------------------------------% +c | Check the count (numcnv) of converged Ritz values with | +c | the number (nconv) reported by dnaupd. If these two | +c | are different then there has probably been an error | +c | caused by incorrect passing of the dnaupd data. | +c %-----------------------------------------------------------% +c + if (msglvl .gt. 2) then + call ivout(logfil, 1, [numcnv], ndigit, + & '_neupd: Number of specified eigenvalues') + call ivout(logfil, 1, [nconv], ndigit, + & '_neupd: Number of "converged" eigenvalues') + end if +c + if (numcnv .ne. nconv) then + info = -15 + go to 9000 + end if +c +c %-----------------------------------------------------------% +c | Call LAPACK routine dlahqr to compute the real Schur form | +c | of the upper Hessenberg matrix returned by DNAUPD . | +c | Make a copy of the upper Hessenberg matrix. | +c | Initialize the Schur vector matrix Q to the identity. | +c %-----------------------------------------------------------% +c + call dcopy (ldh*ncv, workl(ih), 1, workl(iuptri), 1) + call dlaset ('All', ncv, ncv, + & zero , one, workl(invsub), + & ldq) + call dlahqr (.true., .true. , ncv, + & 1 , ncv , workl(iuptri), + & ldh , workl(iheigr), workl(iheigi), + & 1 , ncv , workl(invsub), + & ldq , ierr) + call dcopy (ncv , workl(invsub+ncv-1), ldq, + & workl(ihbds), 1) +c + if (ierr .ne. 0) then + info = -8 + go to 9000 + end if +c + if (msglvl .gt. 1) then + call dvout (logfil, ncv, workl(iheigr), ndigit, + & '_neupd: Real part of the eigenvalues of H') + call dvout (logfil, ncv, workl(iheigi), ndigit, + & '_neupd: Imaginary part of the Eigenvalues of H') + call dvout (logfil, ncv, workl(ihbds), ndigit, + & '_neupd: Last row of the Schur vector matrix') + if (msglvl .gt. 3) then + call dmout (logfil , ncv, ncv , + & workl(iuptri), ldh, ndigit, + & '_neupd: The upper quasi-triangular matrix ') + end if + end if +c + if (reord) then +c +c %-----------------------------------------------------% +c | Reorder the computed upper quasi-triangular matrix. | +c %-----------------------------------------------------% +c + call dtrsen ('None' , 'V' , + & select , ncv , + & workl(iuptri), ldh , + & workl(invsub), ldq , + & workl(iheigr), workl(iheigi), + & nconv , conds , + & sep , workl(ihbds) , + & ncv , iwork , + & 1 , ierr) +c + if (ierr .eq. 1) then + info = 1 + go to 9000 + end if +c + if (msglvl .gt. 2) then + call dvout (logfil, ncv, workl(iheigr), ndigit, + & '_neupd: Real part of the eigenvalues of H--reordered') + call dvout (logfil, ncv, workl(iheigi), ndigit, + & '_neupd: Imag part of the eigenvalues of H--reordered') + if (msglvl .gt. 3) then + call dmout (logfil , ncv, ncv , + & workl(iuptri), ldq, ndigit, + & '_neupd: Quasi-triangular matrix after re-ordering') + end if + end if +c + end if +c +c %---------------------------------------% +c | Copy the last row of the Schur vector | +c | into workl(ihbds). This will be used | +c | to compute the Ritz estimates of | +c | converged Ritz values. | +c %---------------------------------------% +c + call dcopy (ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1) +c +c %----------------------------------------------------% +c | Place the computed eigenvalues of H into DR and DI | +c | if a spectral transformation was not used. | +c %----------------------------------------------------% +c + if (type .eq. 'REGULR') then + call dcopy (nconv, workl(iheigr), 1, dr, 1) + call dcopy (nconv, workl(iheigi), 1, di, 1) + end if +c +c %----------------------------------------------------------% +c | Compute the QR factorization of the matrix representing | +c | the wanted invariant subspace located in the first NCONV | +c | columns of workl(invsub,ldq). | +c %----------------------------------------------------------% +c + call dgeqr2 (ncv, nconv , workl(invsub), + & ldq, workev, workev(ncv+1), + & ierr) +c +c %---------------------------------------------------------% +c | * Postmultiply V by Q using dorm2r . | +c | * Copy the first NCONV columns of VQ into Z. | +c | * Postmultiply Z by R. | +c | The N by NCONV matrix Z is now a matrix representation | +c | of the approximate invariant subspace associated with | +c | the Ritz values in workl(iheigr) and workl(iheigi) | +c | The first NCONV columns of V are now approximate Schur | +c | vectors associated with the real upper quasi-triangular | +c | matrix of order NCONV in workl(iuptri) | +c %---------------------------------------------------------% +c + call dorm2r ('Right', 'Notranspose', n , + & ncv , nconv , workl(invsub), + & ldq , workev , v , + & ldv , workd(n+1) , ierr) + call dlacpy ('All', n, nconv, v, ldv, z, ldz) +c + do 20 j=1, nconv +c +c %---------------------------------------------------% +c | Perform both a column and row scaling if the | +c | diagonal element of workl(invsub,ldq) is negative | +c | I'm lazy and don't take advantage of the upper | +c | quasi-triangular form of workl(iuptri,ldq) | +c | Note that since Q is orthogonal, R is a diagonal | +c | matrix consisting of plus or minus ones | +c %---------------------------------------------------% +c + if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then + call dscal (nconv, -one, workl(iuptri+j-1), ldq) + call dscal (nconv, -one, workl(iuptri+(j-1)*ldq), 1) + end if +c + 20 continue +c + if (howmny .eq. 'A') then +c +c %--------------------------------------------% +c | Compute the NCONV wanted eigenvectors of T | +c | located in workl(iuptri,ldq). | +c %--------------------------------------------% +c + do 30 j=1, ncv + if (j .le. nconv) then + select(j) = .true. + else + select(j) = .false. + end if + 30 continue +c + call dtrevc ('Right', 'Select' , select , + & ncv , workl(iuptri), ldq , + & vl , 1 , workl(invsub), + & ldq , ncv , outncv , + & workev , ierr) +c + if (ierr .ne. 0) then + info = -9 + go to 9000 + end if +c +c %------------------------------------------------% +c | Scale the returning eigenvectors so that their | +c | Euclidean norms are all one. LAPACK subroutine | +c | dtrevc returns each eigenvector normalized so | +c | that the element of largest magnitude has | +c | magnitude 1; | +c %------------------------------------------------% +c + iconj = 0 + do 40 j=1, nconv +c + if ( workl(iheigi+j-1) .eq. zero ) then +c +c %----------------------% +c | real eigenvalue case | +c %----------------------% +c + temp = dnrm2 ( ncv, workl(invsub+(j-1)*ldq), 1 ) + call dscal ( ncv, one / temp, + & workl(invsub+(j-1)*ldq), 1 ) +c + else +c +c %-------------------------------------------% +c | Complex conjugate pair case. Note that | +c | since the real and imaginary part of | +c | the eigenvector are stored in consecutive | +c | columns, we further normalize by the | +c | square root of two. | +c %-------------------------------------------% +c + if (iconj .eq. 0) then + temp = dlapy2 (dnrm2 (ncv, + & workl(invsub+(j-1)*ldq), + & 1), + & dnrm2 (ncv, + & workl(invsub+j*ldq), + & 1)) + call dscal (ncv, one/temp, + & workl(invsub+(j-1)*ldq), 1 ) + call dscal (ncv, one/temp, + & workl(invsub+j*ldq), 1 ) + iconj = 1 + else + iconj = 0 + end if +c + end if +c + 40 continue +c + call dgemv ('T', ncv, nconv, one, workl(invsub), + & ldq, workl(ihbds), 1, zero, workev, 1) +c + iconj = 0 + do 45 j=1, nconv + if (workl(iheigi+j-1) .ne. zero) then +c +c %-------------------------------------------% +c | Complex conjugate pair case. Note that | +c | since the real and imaginary part of | +c | the eigenvector are stored in consecutive | +c %-------------------------------------------% +c + if (iconj .eq. 0) then + workev(j) = dlapy2 (workev(j), workev(j+1)) + workev(j+1) = workev(j) + iconj = 1 + else + iconj = 0 + end if + end if + 45 continue +c + if (msglvl .gt. 2) then + call dcopy (ncv, workl(invsub+ncv-1), ldq, + & workl(ihbds), 1) + call dvout (logfil, ncv, workl(ihbds), ndigit, + & '_neupd: Last row of the eigenvector matrix for T') + if (msglvl .gt. 3) then + call dmout (logfil, ncv, ncv, workl(invsub), ldq, + & ndigit, '_neupd: The eigenvector matrix for T') + end if + end if +c +c %---------------------------------------% +c | Copy Ritz estimates into workl(ihbds) | +c %---------------------------------------% +c + call dcopy (nconv, workev, 1, workl(ihbds), 1) +c +c %---------------------------------------------------------% +c | Compute the QR factorization of the eigenvector matrix | +c | associated with leading portion of T in the first NCONV | +c | columns of workl(invsub,ldq). | +c %---------------------------------------------------------% +c + call dgeqr2 (ncv, nconv , workl(invsub), + & ldq, workev, workev(ncv+1), + & ierr) +c +c %----------------------------------------------% +c | * Postmultiply Z by Q. | +c | * Postmultiply Z by R. | +c | The N by NCONV matrix Z is now contains the | +c | Ritz vectors associated with the Ritz values | +c | in workl(iheigr) and workl(iheigi). | +c %----------------------------------------------% +c + call dorm2r ('Right', 'Notranspose', n , + & ncv , nconv , workl(invsub), + & ldq , workev , z , + & ldz , workd(n+1) , ierr) +c + call dtrmm ('Right' , 'Upper' , 'No transpose', + & 'Non-unit', n , nconv , + & one , workl(invsub), ldq , + & z , ldz) +c + end if +c + else +c +c %------------------------------------------------------% +c | An approximate invariant subspace is not needed. | +c | Place the Ritz values computed DNAUPD into DR and DI | +c %------------------------------------------------------% +c + call dcopy (nconv, workl(ritzr), 1, dr, 1) + call dcopy (nconv, workl(ritzi), 1, di, 1) + call dcopy (nconv, workl(ritzr), 1, workl(iheigr), 1) + call dcopy (nconv, workl(ritzi), 1, workl(iheigi), 1) + call dcopy (nconv, workl(bounds), 1, workl(ihbds), 1) + end if +c +c %------------------------------------------------% +c | Transform the Ritz values and possibly vectors | +c | and corresponding error bounds of OP to those | +c | of A*x = lambda*B*x. | +c %------------------------------------------------% +c + if (type .eq. 'REGULR') then +c + if (rvec) + & call dscal (ncv, rnorm, workl(ihbds), 1) +c + else +c +c %---------------------------------------% +c | A spectral transformation was used. | +c | * Determine the Ritz estimates of the | +c | Ritz values in the original system. | +c %---------------------------------------% +c + if (type .eq. 'SHIFTI') then +c + if (rvec) + & call dscal (ncv, rnorm, workl(ihbds), 1) +c + do 50 k=1, ncv + temp = dlapy2 ( workl(iheigr+k-1), + & workl(iheigi+k-1) ) + workl(ihbds+k-1) = abs( workl(ihbds+k-1) ) + & / temp / temp + 50 continue +c + else if (type .eq. 'REALPT') then +c + do 60 k=1, ncv + 60 continue +c + else if (type .eq. 'IMAGPT') then +c + do 70 k=1, ncv + 70 continue +c + end if +c +c %-----------------------------------------------------------% +c | * Transform the Ritz values back to the original system. | +c | For TYPE = 'SHIFTI' the transformation is | +c | lambda = 1/theta + sigma | +c | For TYPE = 'REALPT' or 'IMAGPT' the user must from | +c | Rayleigh quotients or a projection. See remark 3 above.| +c | NOTES: | +c | *The Ritz vectors are not affected by the transformation. | +c %-----------------------------------------------------------% +c + if (type .eq. 'SHIFTI') then +c + do 80 k=1, ncv + temp = dlapy2 ( workl(iheigr+k-1), + & workl(iheigi+k-1) ) + workl(iheigr+k-1) = workl(iheigr+k-1)/temp/temp + & + sigmar + workl(iheigi+k-1) = -workl(iheigi+k-1)/temp/temp + & + sigmai + 80 continue +c + call dcopy (nconv, workl(iheigr), 1, dr, 1) + call dcopy (nconv, workl(iheigi), 1, di, 1) +c + else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then +c + call dcopy (nconv, workl(iheigr), 1, dr, 1) + call dcopy (nconv, workl(iheigi), 1, di, 1) +c + end if +c + end if +c + if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then + call dvout (logfil, nconv, dr, ndigit, + & '_neupd: Untransformed real part of the Ritz valuess.') + call dvout (logfil, nconv, di, ndigit, + & '_neupd: Untransformed imag part of the Ritz valuess.') + call dvout (logfil, nconv, workl(ihbds), ndigit, + & '_neupd: Ritz estimates of untransformed Ritz values.') + else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then + call dvout (logfil, nconv, dr, ndigit, + & '_neupd: Real parts of converged Ritz values.') + call dvout (logfil, nconv, di, ndigit, + & '_neupd: Imag parts of converged Ritz values.') + call dvout (logfil, nconv, workl(ihbds), ndigit, + & '_neupd: Associated Ritz estimates.') + end if +c +c %-------------------------------------------------% +c | Eigenvector Purification step. Formally perform | +c | one of inverse subspace iteration. Only used | +c | for MODE = 2. | +c %-------------------------------------------------% +c + if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then +c +c %------------------------------------------------% +c | Purify the computed Ritz vectors by adding a | +c | little bit of the residual vector: | +c | T | +c | resid(:)*( e s ) / theta | +c | NCV | +c | where H s = s theta. Remember that when theta | +c | has nonzero imaginary part, the corresponding | +c | Ritz vector is stored across two columns of Z. | +c %------------------------------------------------% +c + iconj = 0 + do 110 j=1, nconv + if (workl(iheigi+j-1) .eq. zero) then + workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / + & workl(iheigr+j-1) + else if (iconj .eq. 0) then + temp = dlapy2 ( workl(iheigr+j-1), workl(iheigi+j-1) ) + workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) * + & workl(iheigr+j-1) + + & workl(invsub+j*ldq+ncv-1) * + & workl(iheigi+j-1) ) / temp / temp + workev(j+1) = ( workl(invsub+j*ldq+ncv-1) * + & workl(iheigr+j-1) - + & workl(invsub+(j-1)*ldq+ncv-1) * + & workl(iheigi+j-1) ) / temp / temp + iconj = 1 + else + iconj = 0 + end if + 110 continue +c +c %---------------------------------------% +c | Perform a rank one update to Z and | +c | purify all the Ritz vectors together. | +c %---------------------------------------% +c + call dger (n, nconv, one, resid, 1, workev, 1, z, ldz) +c + end if +c + 9000 continue +c + return +c +c %---------------% +c | End of DNEUPD | +c %---------------% +c + end diff --git a/src/arpack/dngets.f b/src/arpack/dngets.f new file mode 100644 index 0000000000..4234a8a221 --- /dev/null +++ b/src/arpack/dngets.f @@ -0,0 +1,231 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dngets +c +c\Description: +c Given the eigenvalues of the upper Hessenberg matrix H, +c computes the NP shifts AMU that are zeros of the polynomial of +c degree NP which filters out components of the unwanted eigenvectors +c corresponding to the AMU's based on some given criteria. +c +c NOTE: call this even in the case of user specified shifts in order +c to sort the eigenvalues, and error bounds of H for later use. +c +c\Usage: +c call dngets +c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI ) +c +c\Arguments +c ISHIFT Integer. (INPUT) +c Method for selecting the implicit shifts at each iteration. +c ISHIFT = 0: user specified shifts +c ISHIFT = 1: exact shift with respect to the matrix H. +c +c WHICH Character*2. (INPUT) +c Shift selection criteria. +c 'LM' -> want the KEV eigenvalues of largest magnitude. +c 'SM' -> want the KEV eigenvalues of smallest magnitude. +c 'LR' -> want the KEV eigenvalues of largest real part. +c 'SR' -> want the KEV eigenvalues of smallest real part. +c 'LI' -> want the KEV eigenvalues of largest imaginary part. +c 'SI' -> want the KEV eigenvalues of smallest imaginary part. +c +c KEV Integer. (INPUT/OUTPUT) +c INPUT: KEV+NP is the size of the matrix H. +c OUTPUT: Possibly increases KEV by one to keep complex conjugate +c pairs together. +c +c NP Integer. (INPUT/OUTPUT) +c Number of implicit shifts to be computed. +c OUTPUT: Possibly decreases NP by one to keep complex conjugate +c pairs together. +c +c RITZR, Double precision array of length KEV+NP. (INPUT/OUTPUT) +c RITZI On INPUT, RITZR and RITZI contain the real and imaginary +c parts of the eigenvalues of H. +c On OUTPUT, RITZR and RITZI are sorted so that the unwanted +c eigenvalues are in the first NP locations and the wanted +c portion is in the last KEV locations. When exact shifts are +c selected, the unwanted part corresponds to the shifts to +c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues +c are further sorted so that the ones with largest Ritz values +c are first. +c +c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) +c Error bounds corresponding to the ordering in RITZ. +c +c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. *** +c +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\Routines called: +c dsortc ARPACK sorting routine. +c dcopy Level 1 BLAS that copies one vector to another . +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/92: Version ' 2.1' +c +c\SCCS Information: @(#) +c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +c +c\Remarks +c 1. xxxx +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dngets ( ishift, which, kev, np, ritzr, ritzi, bounds, + & shiftr, shifti ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character*2 which + integer ishift, kev, np +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & bounds(kev+np), ritzr(kev+np), ritzi(kev+np), + & shiftr(1), shifti(1) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0, zero = 0.0) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer msglvl +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dcopy, dsortc, second +c +c %----------------------% +c | Intrinsics Functions | +c %----------------------% +c + intrinsic abs +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = mngets +c +c %----------------------------------------------------% +c | LM, SM, LR, SR, LI, SI case. | +c | Sort the eigenvalues of H into the desired order | +c | and apply the resulting order to BOUNDS. | +c | The eigenvalues are sorted so that the wanted part | +c | are always in the last KEV locations. | +c | We first do a pre-processing sort in order to keep | +c | complex conjugate pairs together | +c %----------------------------------------------------% +c + if (which .eq. 'LM') then + call dsortc ('LR', .true., kev+np, ritzr, ritzi, bounds) + else if (which .eq. 'SM') then + call dsortc ('SR', .true., kev+np, ritzr, ritzi, bounds) + else if (which .eq. 'LR') then + call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) + else if (which .eq. 'SR') then + call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) + else if (which .eq. 'LI') then + call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) + else if (which .eq. 'SI') then + call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) + end if +c + call dsortc (which, .true., kev+np, ritzr, ritzi, bounds) +c +c %-------------------------------------------------------% +c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | +c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | +c | Accordingly decrease NP by one. In other words keep | +c | complex conjugate pairs together. | +c %-------------------------------------------------------% +c + if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero + & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then + np = np - 1 + kev = kev + 1 + end if +c + if ( ishift .eq. 1 ) then +c +c %-------------------------------------------------------% +c | Sort the unwanted Ritz values used as shifts so that | +c | the ones with largest Ritz estimates are first | +c | This will tend to minimize the effects of the | +c | forward instability of the iteration when they shifts | +c | are applied in subroutine dnapps. | +c | Be careful and use 'SR' since we want to sort BOUNDS! | +c %-------------------------------------------------------% +c + call dsortc ( 'SR', .true., np, bounds, ritzr, ritzi ) + end if +c + call arsecond (t1) + tngets = tngets + (t1 - t0) +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [kev], ndigit, '_ngets: KEV is') + call ivout (logfil, 1, [np], ndigit, '_ngets: NP is') + call dvout (logfil, kev+np, ritzr, ndigit, + & '_ngets: Eigenvalues of current H matrix -- real part') + call dvout (logfil, kev+np, ritzi, ndigit, + & '_ngets: Eigenvalues of current H matrix -- imag part') + call dvout (logfil, kev+np, bounds, ndigit, + & '_ngets: Ritz estimates of the current KEV+NP Ritz values') + end if +c + return +c +c %---------------% +c | End of dngets | +c %---------------% +c + end diff --git a/src/arpack/dsaitr.f b/src/arpack/dsaitr.f new file mode 100644 index 0000000000..cb88c93bd8 --- /dev/null +++ b/src/arpack/dsaitr.f @@ -0,0 +1,853 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dsaitr +c +c\Description: +c Reverse communication interface for applying NP additional steps to +c a K step symmetric Arnoldi factorization. +c +c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T +c +c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. +c +c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T +c +c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. +c +c where OP and B are as in dsaupd. The B-norm of r_{k+p} is also +c computed and returned. +c +c\Usage: +c call dsaitr +c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH, +c IPNTR, WORKD, INFO ) +c +c\Arguments +c IDO Integer. (INPUT/OUTPUT) +c Reverse communication flag. +c ------------------------------------------------------------- +c IDO = 0: first call to the reverse communication interface +c IDO = -1: compute Y = OP * X where +c IPNTR(1) is the pointer into WORK for X, +c IPNTR(2) is the pointer into WORK for Y. +c This is for the restart phase to force the new +c starting vector into the range of OP. +c IDO = 1: compute Y = OP * X where +c IPNTR(1) is the pointer into WORK for X, +c IPNTR(2) is the pointer into WORK for Y, +c IPNTR(3) is the pointer into WORK for B * X. +c IDO = 2: compute Y = B * X where +c IPNTR(1) is the pointer into WORK for X, +c IPNTR(2) is the pointer into WORK for Y. +c IDO = 99: done +c ------------------------------------------------------------- +c When the routine is used in the "shift-and-invert" mode, the +c vector B * Q is already available and does not need to be +c recomputed in forming OP * Q. +c +c BMAT Character*1. (INPUT) +c BMAT specifies the type of matrix B that defines the +c semi-inner product for the operator OP. See dsaupd. +c B = 'I' -> standard eigenvalue problem A*x = lambda*x +c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x +c +c N Integer. (INPUT) +c Dimension of the eigenproblem. +c +c K Integer. (INPUT) +c Current order of H and the number of columns of V. +c +c NP Integer. (INPUT) +c Number of additional Arnoldi steps to take. +c +c MODE Integer. (INPUT) +c Signifies which form for "OP". If MODE=2 then +c a reduction in the number of B matrix vector multiplies +c is possible since the B-norm of OP*x is equivalent to +c the inv(B)-norm of A*x. +c +c RESID Double precision array of length N. (INPUT/OUTPUT) +c On INPUT: RESID contains the residual vector r_{k}. +c On OUTPUT: RESID contains the residual vector r_{k+p}. +c +c RNORM Double precision scalar. (INPUT/OUTPUT) +c On INPUT the B-norm of r_{k}. +c On OUTPUT the B-norm of the updated residual r_{k+p}. +c +c V Double precision N by K+NP array. (INPUT/OUTPUT) +c On INPUT: V contains the Arnoldi vectors in the first K +c columns. +c On OUTPUT: V contains the new NP Arnoldi vectors in the next +c NP columns. The first K columns are unchanged. +c +c LDV Integer. (INPUT) +c Leading dimension of V exactly as declared in the calling +c program. +c +c H Double precision (K+NP) by 2 array. (INPUT/OUTPUT) +c H is used to store the generated symmetric tridiagonal matrix +c with the subdiagonal in the first column starting at H(2,1) +c and the main diagonal in the second column. +c +c LDH Integer. (INPUT) +c Leading dimension of H exactly as declared in the calling +c program. +c +c IPNTR Integer array of length 3. (OUTPUT) +c Pointer to mark the starting locations in the WORK for +c vectors used by the Arnoldi iteration. +c ------------------------------------------------------------- +c IPNTR(1): pointer to the current operand vector X. +c IPNTR(2): pointer to the current result vector Y. +c IPNTR(3): pointer to the vector B * X when used in the +c shift-and-invert mode. X is the current operand. +c ------------------------------------------------------------- +c +c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +c Distributed array to be used in the basic Arnoldi iteration +c for reverse communication. The calling program should not +c use WORKD as temporary workspace during the iteration !!!!!! +c On INPUT, WORKD(1:N) = B*RESID where RESID is associated +c with the K step Arnoldi factorization. Used to save some +c computation at the first step. +c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated +c with the K+NP step Arnoldi factorization. +c +c INFO Integer. (OUTPUT) +c = 0: Normal exit. +c > 0: Size of an invariant subspace of OP is found that is +c less than K + NP. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\Routines called: +c dgetv0 ARPACK routine to generate the initial vector. +c ivout ARPACK utility routine that prints integers. +c dmout ARPACK utility routine that prints matrices. +c dvout ARPACK utility routine that prints vectors. +c dlamch LAPACK routine that determines machine constants. +c dlascl LAPACK routine for careful scaling of a matrix. +c dgemv Level 2 BLAS routine for matrix vector multiplication. +c daxpy Level 1 BLAS that computes a vector triad. +c dscal Level 1 BLAS that scales a vector. +c dcopy Level 1 BLAS that copies one vector to another . +c ddot Level 1 BLAS that computes the scalar product of two vectors. +c dnrm2 Level 1 BLAS that computes the norm of a vector. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/93: Version ' 2.4' +c +c\SCCS Information: @(#) +c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2 +c +c\Remarks +c The algorithm implemented is: +c +c restart = .false. +c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; +c r_{k} contains the initial residual vector even for k = 0; +c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already +c computed by the calling program. +c +c betaj = rnorm ; p_{k+1} = B*r_{k} ; +c For j = k+1, ..., k+np Do +c 1) if ( betaj < tol ) stop or restart depending on j. +c if ( restart ) generate a new starting vector. +c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; +c p_{j} = p_{j}/betaj +c 3) r_{j} = OP*v_{j} where OP is defined as in dsaupd +c For shift-invert mode p_{j} = B*v_{j} is already available. +c wnorm = || OP*v_{j} || +c 4) Compute the j-th step residual vector. +c w_{j} = V_{j}^T * B * OP * v_{j} +c r_{j} = OP*v_{j} - V_{j} * w_{j} +c alphaj <- j-th component of w_{j} +c rnorm = || r_{j} || +c betaj+1 = rnorm +c If (rnorm > 0.717*wnorm) accept step and go back to 1) +c 5) Re-orthogonalization step: +c s = V_{j}'*B*r_{j} +c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || +c alphaj = alphaj + s_{j}; +c 6) Iterative refinement step: +c If (rnorm1 > 0.717*rnorm) then +c rnorm = rnorm1 +c accept step and go back to 1) +c Else +c rnorm = rnorm1 +c If this is the first time in step 6), go to 5) +c Else r_{j} lies in the span of V_{j} numerically. +c Set r_{j} = 0 and rnorm = 0; go to 1) +c EndIf +c End Do +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dsaitr + & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh, + & ipntr, workd, info) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character bmat*1 + integer ido, info, k, ldh, ldv, n, mode, np + Double precision + & rnorm +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + integer ipntr(3) + Double precision + & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + logical first, orth1, orth2, rstart, step3, step4 + integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl, + & infol, jj + Double precision + & rnorm1, wnorm, safmin, temp1 + save orth1, orth2, rstart, step3, step4, + & ierr, ipj, irj, ivj, iter, itry, j, msglvl, + & rnorm1, safmin, wnorm +c +c %-----------------------% +c | Local Array Arguments | +c %-----------------------% +c + Double precision + & xtemp(2) +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external daxpy, dcopy, dscal, dgemv, dgetv0, dvout, dmout, + & dlascl, ivout, second +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & ddot, dnrm2, dlamch + external ddot, dnrm2, dlamch +c +c %-----------------% +c | Data statements | +c %-----------------% +c + data first / .true. / +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + if (first) then + first = .false. +c +c %--------------------------------% +c | safmin = safe minimum is such | +c | that 1/sfmin does not overflow | +c %--------------------------------% +c + safmin = dlamch('safmin') + end if +c + if (ido .eq. 0) then +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = msaitr +c +c %------------------------------% +c | Initial call to this routine | +c %------------------------------% +c + info = 0 + step3 = .false. + step4 = .false. + rstart = .false. + orth1 = .false. + orth2 = .false. +c +c %--------------------------------% +c | Pointer to the current step of | +c | the factorization to build | +c %--------------------------------% +c + j = k + 1 +c +c %------------------------------------------% +c | Pointers used for reverse communication | +c | when using WORKD. | +c %------------------------------------------% +c + ipj = 1 + irj = ipj + n + ivj = irj + n + end if +c +c %-------------------------------------------------% +c | When in reverse communication mode one of: | +c | STEP3, STEP4, ORTH1, ORTH2, RSTART | +c | will be .true. | +c | STEP3: return from computing OP*v_{j}. | +c | STEP4: return from computing B-norm of OP*v_{j} | +c | ORTH1: return from computing B-norm of r_{j+1} | +c | ORTH2: return from computing B-norm of | +c | correction to the residual vector. | +c | RSTART: return from OP computations needed by | +c | dgetv0. | +c %-------------------------------------------------% +c + if (step3) go to 50 + if (step4) go to 60 + if (orth1) go to 70 + if (orth2) go to 90 + if (rstart) go to 30 +c +c %------------------------------% +c | Else this is the first step. | +c %------------------------------% +c +c %--------------------------------------------------------------% +c | | +c | A R N O L D I I T E R A T I O N L O O P | +c | | +c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | +c %--------------------------------------------------------------% +c + 1000 continue +c + if (msglvl .gt. 2) then + call ivout (logfil, 1, [j], ndigit, + & '_saitr: generating Arnoldi vector no.') + call dvout (logfil, 1, [rnorm], ndigit, + & '_saitr: B-norm of the current residual =') + end if +c +c %---------------------------------------------------------% +c | Check for exact zero. Equivalent to determing whether a | +c | j-step Arnoldi factorization is present. | +c %---------------------------------------------------------% +c + if (rnorm .gt. zero) go to 40 +c +c %---------------------------------------------------% +c | Invariant subspace found, generate a new starting | +c | vector which is orthogonal to the current Arnoldi | +c | basis and continue the iteration. | +c %---------------------------------------------------% +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [j], ndigit, + & '_saitr: ****** restart at step ******') + end if +c +c %---------------------------------------------% +c | ITRY is the loop variable that controls the | +c | maximum amount of times that a restart is | +c | attempted. NRSTRT is used by stat.h | +c %---------------------------------------------% +c + nrstrt = nrstrt + 1 + itry = 1 + 20 continue + rstart = .true. + ido = 0 + 30 continue +c +c %--------------------------------------% +c | If in reverse communication mode and | +c | RSTART = .true. flow returns here. | +c %--------------------------------------% +c + call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, + & resid, rnorm, ipntr, workd, ierr) + if (ido .ne. 99) go to 9000 + if (ierr .lt. 0) then + itry = itry + 1 + if (itry .le. 3) go to 20 +c +c %------------------------------------------------% +c | Give up after several restart attempts. | +c | Set INFO to the size of the invariant subspace | +c | which spans OP and exit. | +c %------------------------------------------------% +c + info = j - 1 + call arsecond (t1) + tsaitr = tsaitr + (t1 - t0) + ido = 99 + go to 9000 + end if +c + 40 continue +c +c %---------------------------------------------------------% +c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | +c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | +c | when reciprocating a small RNORM, test against lower | +c | machine bound. | +c %---------------------------------------------------------% +c + call dcopy (n, resid, 1, v(1,j), 1) + if (rnorm .ge. safmin) then + temp1 = one / rnorm + call dscal (n, temp1, v(1,j), 1) + call dscal (n, temp1, workd(ipj), 1) + else +c +c %-----------------------------------------% +c | To scale both v_{j} and p_{j} carefully | +c | use LAPACK routine SLASCL | +c %-----------------------------------------% +c + call dlascl ('General', i, i, rnorm, one, n, 1, + & v(1,j), n, infol) + call dlascl ('General', i, i, rnorm, one, n, 1, + & workd(ipj), n, infol) + end if +c +c %------------------------------------------------------% +c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | +c | Note that this is not quite yet r_{j}. See STEP 4 | +c %------------------------------------------------------% +c + step3 = .true. + nopx = nopx + 1 + call arsecond (t2) + call dcopy (n, v(1,j), 1, workd(ivj), 1) + ipntr(1) = ivj + ipntr(2) = irj + ipntr(3) = ipj + ido = 1 +c +c %-----------------------------------% +c | Exit in order to compute OP*v_{j} | +c %-----------------------------------% +c + go to 9000 + 50 continue +c +c %-----------------------------------% +c | Back from reverse communication; | +c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. | +c %-----------------------------------% +c + call arsecond (t3) + tmvopx = tmvopx + (t3 - t2) +c + step3 = .false. +c +c %------------------------------------------% +c | Put another copy of OP*v_{j} into RESID. | +c %------------------------------------------% +c + call dcopy (n, workd(irj), 1, resid, 1) +c +c %-------------------------------------------% +c | STEP 4: Finish extending the symmetric | +c | Arnoldi to length j. If MODE = 2 | +c | then B*OP = B*inv(B)*A = A and | +c | we don't need to compute B*OP. | +c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is | +c | assumed to have A*v_{j}. | +c %-------------------------------------------% +c + if (mode .eq. 2) go to 65 + call arsecond (t2) + if (bmat .eq. 'G') then + nbx = nbx + 1 + step4 = .true. + ipntr(1) = irj + ipntr(2) = ipj + ido = 2 +c +c %-------------------------------------% +c | Exit in order to compute B*OP*v_{j} | +c %-------------------------------------% +c + go to 9000 + else if (bmat .eq. 'I') then + call dcopy(n, resid, 1 , workd(ipj), 1) + end if + 60 continue +c +c %-----------------------------------% +c | Back from reverse communication; | +c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. | +c %-----------------------------------% +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c + step4 = .false. +c +c %-------------------------------------% +c | The following is needed for STEP 5. | +c | Compute the B-norm of OP*v_{j}. | +c %-------------------------------------% +c + 65 continue + if (mode .eq. 2) then +c +c %----------------------------------% +c | Note that the B-norm of OP*v_{j} | +c | is the inv(B)-norm of A*v_{j}. | +c %----------------------------------% +c + wnorm = ddot (n, resid, 1, workd(ivj), 1) + wnorm = sqrt(abs(wnorm)) + else if (bmat .eq. 'G') then + wnorm = ddot (n, resid, 1, workd(ipj), 1) + wnorm = sqrt(abs(wnorm)) + else if (bmat .eq. 'I') then + wnorm = dnrm2(n, resid, 1) + end if +c +c %-----------------------------------------% +c | Compute the j-th residual corresponding | +c | to the j step factorization. | +c | Use Classical Gram Schmidt and compute: | +c | w_{j} <- V_{j}^T * B * OP * v_{j} | +c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | +c %-----------------------------------------% +c +c +c %------------------------------------------% +c | Compute the j Fourier coefficients w_{j} | +c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | +c %------------------------------------------% +c + if (mode .ne. 2 ) then + call dgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero, + & workd(irj), 1) + else if (mode .eq. 2) then + call dgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero, + & workd(irj), 1) + end if +c +c %--------------------------------------% +c | Orthgonalize r_{j} against V_{j}. | +c | RESID contains OP*v_{j}. See STEP 3. | +c %--------------------------------------% +c + call dgemv('N', n, j, -one, v, ldv, workd(irj), 1, one, + & resid, 1) +c +c %--------------------------------------% +c | Extend H to have j rows and columns. | +c %--------------------------------------% +c + h(j,2) = workd(irj + j - 1) + if (j .eq. 1 .or. rstart) then + h(j,1) = zero + else + h(j,1) = rnorm + end if + call arsecond (t4) +c + orth1 = .true. + iter = 0 +c + call arsecond (t2) + if (bmat .eq. 'G') then + nbx = nbx + 1 + call dcopy (n, resid, 1, workd(irj), 1) + ipntr(1) = irj + ipntr(2) = ipj + ido = 2 +c +c %----------------------------------% +c | Exit in order to compute B*r_{j} | +c %----------------------------------% +c + go to 9000 + else if (bmat .eq. 'I') then + call dcopy (n, resid, 1, workd(ipj), 1) + end if + 70 continue +c +c %---------------------------------------------------% +c | Back from reverse communication if ORTH1 = .true. | +c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | +c %---------------------------------------------------% +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c + orth1 = .false. +c +c %------------------------------% +c | Compute the B-norm of r_{j}. | +c %------------------------------% +c + if (bmat .eq. 'G') then + rnorm = ddot (n, resid, 1, workd(ipj), 1) + rnorm = sqrt(abs(rnorm)) + else if (bmat .eq. 'I') then + rnorm = dnrm2(n, resid, 1) + end if +c +c %-----------------------------------------------------------% +c | STEP 5: Re-orthogonalization / Iterative refinement phase | +c | Maximum NITER_ITREF tries. | +c | | +c | s = V_{j}^T * B * r_{j} | +c | r_{j} = r_{j} - V_{j}*s | +c | alphaj = alphaj + s_{j} | +c | | +c | The stopping criteria used for iterative refinement is | +c | discussed in Parlett's book SEP, page 107 and in Gragg & | +c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | +c | Determine if we need to correct the residual. The goal is | +c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | +c %-----------------------------------------------------------% +c + if (rnorm .gt. 0.717*wnorm) go to 100 + nrorth = nrorth + 1 +c +c %---------------------------------------------------% +c | Enter the Iterative refinement phase. If further | +c | refinement is necessary, loop back here. The loop | +c | variable is ITER. Perform a step of Classical | +c | Gram-Schmidt using all the Arnoldi vectors V_{j} | +c %---------------------------------------------------% +c + 80 continue +c + if (msglvl .gt. 2) then + xtemp(1) = wnorm + xtemp(2) = rnorm + call dvout (logfil, 2, xtemp, ndigit, + & '_saitr: re-orthonalization ; wnorm and rnorm are') + end if +c +c %----------------------------------------------------% +c | Compute V_{j}^T * B * r_{j}. | +c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | +c %----------------------------------------------------% +c + call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, + & zero, workd(irj), 1) +c +c %----------------------------------------------% +c | Compute the correction to the residual: | +c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | +c | The correction to H is v(:,1:J)*H(1:J,1:J) + | +c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only | +c | H(j,j) is updated. | +c %----------------------------------------------% +c + call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, + & one, resid, 1) +c + if (j .eq. 1 .or. rstart) h(j,1) = zero + h(j,2) = h(j,2) + workd(irj + j - 1) +c + orth2 = .true. + call arsecond (t2) + if (bmat .eq. 'G') then + nbx = nbx + 1 + call dcopy (n, resid, 1, workd(irj), 1) + ipntr(1) = irj + ipntr(2) = ipj + ido = 2 +c +c %-----------------------------------% +c | Exit in order to compute B*r_{j}. | +c | r_{j} is the corrected residual. | +c %-----------------------------------% +c + go to 9000 + else if (bmat .eq. 'I') then + call dcopy (n, resid, 1, workd(ipj), 1) + end if + 90 continue +c +c %---------------------------------------------------% +c | Back from reverse communication if ORTH2 = .true. | +c %---------------------------------------------------% +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c +c %-----------------------------------------------------% +c | Compute the B-norm of the corrected residual r_{j}. | +c %-----------------------------------------------------% +c + if (bmat .eq. 'G') then + rnorm1 = ddot (n, resid, 1, workd(ipj), 1) + rnorm1 = sqrt(abs(rnorm1)) + else if (bmat .eq. 'I') then + rnorm1 = dnrm2(n, resid, 1) + end if +c + if (msglvl .gt. 0 .and. iter .gt. 0) then + call ivout (logfil, 1, [j], ndigit, + & '_saitr: Iterative refinement for Arnoldi residual') + if (msglvl .gt. 2) then + xtemp(1) = rnorm + xtemp(2) = rnorm1 + call dvout (logfil, 2, xtemp, ndigit, + & '_saitr: iterative refinement ; rnorm and rnorm1 are') + end if + end if +c +c %-----------------------------------------% +c | Determine if we need to perform another | +c | step of re-orthogonalization. | +c %-----------------------------------------% +c + if (rnorm1 .gt. 0.717*rnorm) then +c +c %--------------------------------% +c | No need for further refinement | +c %--------------------------------% +c + rnorm = rnorm1 +c + else +c +c %-------------------------------------------% +c | Another step of iterative refinement step | +c | is required. NITREF is used by stat.h | +c %-------------------------------------------% +c + nitref = nitref + 1 + rnorm = rnorm1 + iter = iter + 1 + if (iter .le. 1) go to 80 +c +c %-------------------------------------------------% +c | Otherwise RESID is numerically in the span of V | +c %-------------------------------------------------% +c + do 95 jj = 1, n + resid(jj) = zero + 95 continue + rnorm = zero + end if +c +c %----------------------------------------------% +c | Branch here directly if iterative refinement | +c | wasn't necessary or after at most NITER_REF | +c | steps of iterative refinement. | +c %----------------------------------------------% +c + 100 continue +c + rstart = .false. + orth2 = .false. +c + call arsecond (t5) + titref = titref + (t5 - t4) +c +c %----------------------------------------------------------% +c | Make sure the last off-diagonal element is non negative | +c | If not perform a similarity transformation on H(1:j,1:j) | +c | and scale v(:,j) by -1. | +c %----------------------------------------------------------% +c + if (h(j,1) .lt. zero) then + h(j,1) = -h(j,1) + if ( j .lt. k+np) then + call dscal(n, -one, v(1,j+1), 1) + else + call dscal(n, -one, resid, 1) + end if + end if +c +c %------------------------------------% +c | STEP 6: Update j = j+1; Continue | +c %------------------------------------% +c + j = j + 1 + if (j .gt. k+np) then + call arsecond (t1) + tsaitr = tsaitr + (t1 - t0) + ido = 99 +c + if (msglvl .gt. 1) then + call dvout (logfil, k+np, h(1,2), ndigit, + & '_saitr: main diagonal of matrix H of step K+NP.') + if (k+np .gt. 1) then + call dvout (logfil, k+np-1, h(2,1), ndigit, + & '_saitr: sub diagonal of matrix H of step K+NP.') + end if + end if +c + go to 9000 + end if +c +c %--------------------------------------------------------% +c | Loop back to extend the factorization by another step. | +c %--------------------------------------------------------% +c + go to 1000 +c +c %---------------------------------------------------------------% +c | | +c | E N D O F M A I N I T E R A T I O N L O O P | +c | | +c %---------------------------------------------------------------% +c + 9000 continue + return +c +c %---------------% +c | End of dsaitr | +c %---------------% +c + end diff --git a/src/arpack/dsapps.f b/src/arpack/dsapps.f new file mode 100644 index 0000000000..d050741423 --- /dev/null +++ b/src/arpack/dsapps.f @@ -0,0 +1,516 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dsapps +c +c\Description: +c Given the Arnoldi factorization +c +c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, +c +c apply NP shifts implicitly resulting in +c +c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q +c +c where Q is an orthogonal matrix of order KEV+NP. Q is the product of +c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi +c factorization becomes: +c +c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. +c +c\Usage: +c call dsapps +c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD ) +c +c\Arguments +c N Integer. (INPUT) +c Problem size, i.e. dimension of matrix A. +c +c KEV Integer. (INPUT) +c INPUT: KEV+NP is the size of the input matrix H. +c OUTPUT: KEV is the size of the updated matrix HNEW. +c +c NP Integer. (INPUT) +c Number of implicit shifts to be applied. +c +c SHIFT Double precision array of length NP. (INPUT) +c The shifts to be applied. +c +c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) +c INPUT: V contains the current KEV+NP Arnoldi vectors. +c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors +c are in the first KEV columns of V. +c +c LDV Integer. (INPUT) +c Leading dimension of V exactly as declared in the calling +c program. +c +c H Double precision (KEV+NP) by 2 array. (INPUT/OUTPUT) +c INPUT: H contains the symmetric tridiagonal matrix of the +c Arnoldi factorization with the subdiagonal in the 1st column +c starting at H(2,1) and the main diagonal in the 2nd column. +c OUTPUT: H contains the updated tridiagonal matrix in the +c KEV leading submatrix. +c +c LDH Integer. (INPUT) +c Leading dimension of H exactly as declared in the calling +c program. +c +c RESID Double precision array of length (N). (INPUT/OUTPUT) +c INPUT: RESID contains the the residual vector r_{k+p}. +c OUTPUT: RESID is the updated residual vector rnew_{k}. +c +c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) +c Work array used to accumulate the rotations during the bulge +c chase sweep. +c +c LDQ Integer. (INPUT) +c Leading dimension of Q exactly as declared in the calling +c program. +c +c WORKD Double precision work array of length 2*N. (WORKSPACE) +c Distributed array used in the application of the accumulated +c orthogonal matrix Q. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +c Restarted Arnoldi Iteration", Rice University Technical Report +c TR95-13, Department of Computational and Applied Mathematics. +c +c\Routines called: +c ivout ARPACK utility routine that prints integers. +c second ARPACK utility routine for timing. +c dvout ARPACK utility routine that prints vectors. +c dlamch LAPACK routine that determines machine constants. +c dlartg LAPACK Givens rotation construction routine. +c dlacpy LAPACK matrix copy routine. +c dlaset LAPACK matrix initialization routine. +c dgemv Level 2 BLAS routine for matrix vector multiplication. +c daxpy Level 1 BLAS that computes a vector triad. +c dcopy Level 1 BLAS that copies one vector to another. +c dscal Level 1 BLAS that scales a vector. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c 12/16/93: Version ' 2.4' +c +c\SCCS Information: @(#) +c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2 +c +c\Remarks +c 1. In this version, each shift is applied to all the subblocks of +c the tridiagonal matrix H and not just to the submatrix that it +c comes from. This routine assumes that the subdiagonal elements +c of H that are stored in h(1:kev+np,1) are nonegative upon input +c and enforce this condition upon output. This version incorporates +c deflation. See code for documentation. +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dsapps + & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + integer kev, ldh, ldq, ldv, n, np +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & h(ldh,2), q(ldq,kev+np), resid(n), shift(np), + & v(ldv,kev+np), workd(2*n) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer i, iend, istart, itop, j, jj, kplusp, msglvl + logical first + Double precision + & a1, a2, a3, a4, big, c, epsmch, f, g, r, s + save epsmch, first +c +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external daxpy, dcopy, dscal, dlacpy, dlartg, dlaset, dvout, + & ivout, second, dgemv +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dlamch + external dlamch +c +c %----------------------% +c | Intrinsics Functions | +c %----------------------% +c + intrinsic abs +c +c %----------------% +c | Data statments | +c %----------------% +c + data first / .true. / +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + if (first) then + epsmch = dlamch('Epsilon-Machine') + first = .false. + end if + itop = 1 +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = msapps +c + kplusp = kev + np +c +c %----------------------------------------------% +c | Initialize Q to the identity matrix of order | +c | kplusp used to accumulate the rotations. | +c %----------------------------------------------% +c + call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) +c +c %----------------------------------------------% +c | Quick return if there are no shifts to apply | +c %----------------------------------------------% +c + if (np .eq. 0) go to 9000 +c +c %----------------------------------------------------------% +c | Apply the np shifts implicitly. Apply each shift to the | +c | whole matrix and not just to the submatrix from which it | +c | comes. | +c %----------------------------------------------------------% +c + do 90 jj = 1, np +c + istart = itop +c +c %----------------------------------------------------------% +c | Check for splitting and deflation. Currently we consider | +c | an off-diagonal element h(i+1,1) negligible if | +c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | +c | for i=1:KEV+NP-1. | +c | If above condition tests true then we set h(i+1,1) = 0. | +c | Note that h(1:KEV+NP,1) are assumed to be non negative. | +c %----------------------------------------------------------% +c + 20 continue +c +c %------------------------------------------------% +c | The following loop exits early if we encounter | +c | a negligible off diagonal element. | +c %------------------------------------------------% +c + do 30 i = istart, kplusp-1 + big = abs(h(i,2)) + abs(h(i+1,2)) + if (h(i+1,1) .le. epsmch*big) then + if (msglvl .gt. 0) then + call ivout (logfil, 1, [i], ndigit, + & '_sapps: deflation at row/column no.') + call ivout (logfil, 1, [jj], ndigit, + & '_sapps: occured before shift number.') + call dvout (logfil, 1, h(i+1,1), ndigit, + & '_sapps: the corresponding off diagonal element') + end if + h(i+1,1) = zero + iend = i + go to 40 + end if + 30 continue + iend = kplusp + 40 continue +c + if (istart .lt. iend) then +c +c %--------------------------------------------------------% +c | Construct the plane rotation G'(istart,istart+1,theta) | +c | that attempts to drive h(istart+1,1) to zero. | +c %--------------------------------------------------------% +c + f = h(istart,2) - shift(jj) + g = h(istart+1,1) + call dlartg (f, g, c, s, r) +c +c %-------------------------------------------------------% +c | Apply rotation to the left and right of H; | +c | H <- G' * H * G, where G = G(istart,istart+1,theta). | +c | This will create a "bulge". | +c %-------------------------------------------------------% +c + a1 = c*h(istart,2) + s*h(istart+1,1) + a2 = c*h(istart+1,1) + s*h(istart+1,2) + a4 = c*h(istart+1,2) - s*h(istart+1,1) + a3 = c*h(istart+1,1) - s*h(istart,2) + h(istart,2) = c*a1 + s*a2 + h(istart+1,2) = c*a4 - s*a3 + h(istart+1,1) = c*a3 + s*a4 +c +c %----------------------------------------------------% +c | Accumulate the rotation in the matrix Q; Q <- Q*G | +c %----------------------------------------------------% +c + do 60 j = 1, min(istart+jj,kplusp) + a1 = c*q(j,istart) + s*q(j,istart+1) + q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) + q(j,istart) = a1 + 60 continue +c +c +c %----------------------------------------------% +c | The following loop chases the bulge created. | +c | Note that the previous rotation may also be | +c | done within the following loop. But it is | +c | kept separate to make the distinction among | +c | the bulge chasing sweeps and the first plane | +c | rotation designed to drive h(istart+1,1) to | +c | zero. | +c %----------------------------------------------% +c + do 70 i = istart+1, iend-1 +c +c %----------------------------------------------% +c | Construct the plane rotation G'(i,i+1,theta) | +c | that zeros the i-th bulge that was created | +c | by G(i-1,i,theta). g represents the bulge. | +c %----------------------------------------------% +c + f = h(i,1) + g = s*h(i+1,1) +c +c %----------------------------------% +c | Final update with G(i-1,i,theta) | +c %----------------------------------% +c + h(i+1,1) = c*h(i+1,1) + call dlartg (f, g, c, s, r) +c +c %-------------------------------------------% +c | The following ensures that h(1:iend-1,1), | +c | the first iend-2 off diagonal of elements | +c | H, remain non negative. | +c %-------------------------------------------% +c + if (r .lt. zero) then + r = -r + c = -c + s = -s + end if +c +c %--------------------------------------------% +c | Apply rotation to the left and right of H; | +c | H <- G * H * G', where G = G(i,i+1,theta) | +c %--------------------------------------------% +c + h(i,1) = r +c + a1 = c*h(i,2) + s*h(i+1,1) + a2 = c*h(i+1,1) + s*h(i+1,2) + a3 = c*h(i+1,1) - s*h(i,2) + a4 = c*h(i+1,2) - s*h(i+1,1) +c + h(i,2) = c*a1 + s*a2 + h(i+1,2) = c*a4 - s*a3 + h(i+1,1) = c*a3 + s*a4 +c +c %----------------------------------------------------% +c | Accumulate the rotation in the matrix Q; Q <- Q*G | +c %----------------------------------------------------% +c + do 50 j = 1, min( i+jj, kplusp ) + a1 = c*q(j,i) + s*q(j,i+1) + q(j,i+1) = - s*q(j,i) + c*q(j,i+1) + q(j,i) = a1 + 50 continue +c + 70 continue +c + end if +c +c %--------------------------% +c | Update the block pointer | +c %--------------------------% +c + istart = iend + 1 +c +c %------------------------------------------% +c | Make sure that h(iend,1) is non-negative | +c | If not then set h(iend,1) <-- -h(iend,1) | +c | and negate the last column of Q. | +c | We have effectively carried out a | +c | similarity on transformation H | +c %------------------------------------------% +c + if (h(iend,1) .lt. zero) then + h(iend,1) = -h(iend,1) + call dscal(kplusp, -one, q(1,iend), 1) + end if +c +c %--------------------------------------------------------% +c | Apply the same shift to the next block if there is any | +c %--------------------------------------------------------% +c + if (iend .lt. kplusp) go to 20 +c +c %-----------------------------------------------------% +c | Check if we can increase the the start of the block | +c %-----------------------------------------------------% +c + do 80 i = itop, kplusp-1 + if (h(i+1,1) .gt. zero) go to 90 + itop = itop + 1 + 80 continue +c +c %-----------------------------------% +c | Finished applying the jj-th shift | +c %-----------------------------------% +c + 90 continue +c +c %------------------------------------------% +c | All shifts have been applied. Check for | +c | more possible deflation that might occur | +c | after the last shift is applied. | +c %------------------------------------------% +c + do 100 i = itop, kplusp-1 + big = abs(h(i,2)) + abs(h(i+1,2)) + if (h(i+1,1) .le. epsmch*big) then + if (msglvl .gt. 0) then + call ivout (logfil, 1, [i], ndigit, + & '_sapps: deflation at row/column no.') + call dvout (logfil, 1, h(i+1,1), ndigit, + & '_sapps: the corresponding off diagonal element') + end if + h(i+1,1) = zero + end if + 100 continue +c +c %-------------------------------------------------% +c | Compute the (kev+1)-st column of (V*Q) and | +c | temporarily store the result in WORKD(N+1:2*N). | +c | This is not necessary if h(kev+1,1) = 0. | +c %-------------------------------------------------% +c + if ( h(kev+1,1) .gt. zero ) + & call dgemv ('N', n, kplusp, one, v, ldv, + & q(1,kev+1), 1, zero, workd(n+1), 1) +c +c %-------------------------------------------------------% +c | Compute column 1 to kev of (V*Q) in backward order | +c | taking advantage that Q is an upper triangular matrix | +c | with lower bandwidth np. | +c | Place results in v(:,kplusp-kev:kplusp) temporarily. | +c %-------------------------------------------------------% +c + do 130 i = 1, kev + call dgemv ('N', n, kplusp-i+1, one, v, ldv, + & q(1,kev-i+1), 1, zero, workd, 1) + call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) + 130 continue +c +c %-------------------------------------------------% +c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | +c %-------------------------------------------------% +c + call dlacpy ('All', n, kev, v(1,np+1), ldv, v, ldv) +c +c %--------------------------------------------% +c | Copy the (kev+1)-st column of (V*Q) in the | +c | appropriate place if h(kev+1,1) .ne. zero. | +c %--------------------------------------------% +c + if ( h(kev+1,1) .gt. zero ) + & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) +c +c %-------------------------------------% +c | Update the residual vector: | +c | r <- sigmak*r + betak*v(:,kev+1) | +c | where | +c | sigmak = (e_{kev+p}'*Q)*e_{kev} | +c | betak = e_{kev+1}'*H*e_{kev} | +c %-------------------------------------% +c + call dscal (n, q(kplusp,kev), resid, 1) + if (h(kev+1,1) .gt. zero) + & call daxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1) +c + if (msglvl .gt. 1) then + call dvout (logfil, 1, q(kplusp,kev), ndigit, + & '_sapps: sigmak of the updated residual vector') + call dvout (logfil, 1, h(kev+1,1), ndigit, + & '_sapps: betak of the updated residual vector') + call dvout (logfil, kev, h(1,2), ndigit, + & '_sapps: updated main diagonal of H for next iteration') + if (kev .gt. 1) then + call dvout (logfil, kev-1, h(2,1), ndigit, + & '_sapps: updated sub diagonal of H for next iteration') + end if + end if +c + call arsecond (t1) + tsapps = tsapps + (t1 - t0) +c + 9000 continue + return +c +c %---------------% +c | End of dsapps | +c %---------------% +c + end diff --git a/src/arpack/dsaup2.f b/src/arpack/dsaup2.f new file mode 100644 index 0000000000..9525301933 --- /dev/null +++ b/src/arpack/dsaup2.f @@ -0,0 +1,850 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dsaup2 +c +c\Description: +c Intermediate level interface called by dsaupd. +c +c\Usage: +c call dsaup2 +c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, +c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, +c IPNTR, WORKD, INFO ) +c +c\Arguments +c +c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dsaupd. +c MODE, ISHIFT, MXITER: see the definition of IPARAM in dsaupd. +c +c NP Integer. (INPUT/OUTPUT) +c Contains the number of implicit shifts to apply during +c each Arnoldi/Lanczos iteration. +c If ISHIFT=1, NP is adjusted dynamically at each iteration +c to accelerate convergence and prevent stagnation. +c This is also roughly equal to the number of matrix-vector +c products (involving the operator OP) per Arnoldi iteration. +c The logic for adjusting is contained within the current +c subroutine. +c If ISHIFT=0, NP is the number of shifts the user needs +c to provide via reverse comunication. 0 < NP < NCV-NEV. +c NP may be less than NCV-NEV since a leading block of the current +c upper Tridiagonal matrix has split off and contains "unwanted" +c Ritz values. +c Upon termination of the IRA iteration, NP contains the number +c of "converged" wanted Ritz values. +c +c IUPD Integer. (INPUT) +c IUPD .EQ. 0: use explicit restart instead implicit update. +c IUPD .NE. 0: use implicit update. +c +c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) +c The Lanczos basis vectors. +c +c LDV Integer. (INPUT) +c Leading dimension of V exactly as declared in the calling +c program. +c +c H Double precision (NEV+NP) by 2 array. (OUTPUT) +c H is used to store the generated symmetric tridiagonal matrix +c The subdiagonal is stored in the first column of H starting +c at H(2,1). The main diagonal is stored in the second column +c of H starting at H(1,2). If dsaup2 converges store the +c B-norm of the final residual vector in H(1,1). +c +c LDH Integer. (INPUT) +c Leading dimension of H exactly as declared in the calling +c program. +c +c RITZ Double precision array of length NEV+NP. (OUTPUT) +c RITZ(1:NEV) contains the computed Ritz values of OP. +c +c BOUNDS Double precision array of length NEV+NP. (OUTPUT) +c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ. +c +c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) +c Private (replicated) work array used to accumulate the +c rotation in the shift application step. +c +c LDQ Integer. (INPUT) +c Leading dimension of Q exactly as declared in the calling +c program. +c +c WORKL Double precision array of length at least 3*(NEV+NP). (INPUT/WORKSPACE) +c Private (replicated) array on each PE or array allocated on +c the front end. It is used in the computation of the +c tridiagonal eigenvalue problem, the calculation and +c application of the shifts and convergence checking. +c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations +c of WORKL are used in reverse communication to hold the user +c supplied shifts. +c +c IPNTR Integer array of length 3. (OUTPUT) +c Pointer to mark the starting locations in the WORKD for +c vectors used by the Lanczos iteration. +c ------------------------------------------------------------- +c IPNTR(1): pointer to the current operand vector X. +c IPNTR(2): pointer to the current result vector Y. +c IPNTR(3): pointer to the vector B * X when used in one of +c the spectral transformation modes. X is the current +c operand. +c ------------------------------------------------------------- +c +c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +c Distributed array to be used in the basic Lanczos iteration +c for reverse communication. The user should not use WORKD +c as temporary workspace during the iteration !!!!!!!!!! +c See Data Distribution Note in dsaupd. +c +c INFO Integer. (INPUT/OUTPUT) +c If INFO .EQ. 0, a randomly initial residual vector is used. +c If INFO .NE. 0, RESID contains the initial residual vector, +c possibly from a previous run. +c Error flag on output. +c = 0: Normal return. +c = 1: All possible eigenvalues of OP has been found. +c NP returns the size of the invariant subspace +c spanning the operator OP. +c = 2: No shifts could be applied. +c = -8: Error return from trid. eigenvalue calculation; +c This should never happen. +c = -9: Starting vector is zero. +c = -9999: Could not build an Lanczos factorization. +c Size that was built in returned in NP. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +c Restarted Arnoldi Iteration", Rice University Technical Report +c TR95-13, Department of Computational and Applied Mathematics. +c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, +c 1980. +c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", +c Computer Physics Communications, 53 (1989), pp 169-179. +c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to +c Implement the Spectral Transformation", Math. Comp., 48 (1987), +c pp 663-673. +c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos +c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", +c SIAM J. Matr. Anal. Apps., January (1993). +c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines +c for Updating the QR decomposition", ACM TOMS, December 1990, +c Volume 16 Number 4, pp 369-377. +c +c\Routines called: +c dgetv0 ARPACK initial vector generation routine. +c dsaitr ARPACK Lanczos factorization routine. +c dsapps ARPACK application of implicit shifts routine. +c dsconv ARPACK convergence of Ritz values routine. +c dseigt ARPACK compute Ritz values and error bounds routine. +c dsgets ARPACK reorder Ritz values and error bounds routine. +c dsortr ARPACK sorting routine. +c ivout ARPACK utility routine that prints integers. +c second ARPACK utility routine for timing. +c dvout ARPACK utility routine that prints vectors. +c dlamch LAPACK routine that determines machine constants. +c dcopy Level 1 BLAS that copies one vector to another. +c ddot Level 1 BLAS that computes the scalar product of two vectors. +c dnrm2 Level 1 BLAS that computes the norm of a vector. +c dscal Level 1 BLAS that scales a vector. +c dswap Level 1 BLAS that swaps two vectors. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c 12/15/93: Version ' 2.4' +c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq) +c +c\SCCS Information: @(#) +c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2 +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dsaup2 + & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, + & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, + & q, ldq, workl, ipntr, workd, info ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character bmat*1, which*2 + integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter, + & n, mode, nev, np + Double precision + & tol +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + integer ipntr(3) + Double precision + & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n), + & ritz(nev+np), v(ldv,nev+np), workd(3*n), + & workl(3*(nev+np)) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + character wprime*2 + logical cnorm, getv0, initv, update, ushift + integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0, + & np0, nptemp, nevd2, nevm2, kp(3) + Double precision + & rnorm, temp, eps23 + save cnorm, getv0, initv, update, ushift, + & iter, kplusp, msglvl, nconv, nev0, np0, + & rnorm, eps23 +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dcopy, dgetv0, dsaitr, dscal, dsconv, dseigt, dsgets, + & dsapps, dsortr, dvout, ivout, second, dswap +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & ddot, dnrm2, dlamch + external ddot, dnrm2, dlamch +c +c %---------------------% +c | Intrinsic Functions | +c %---------------------% +c + intrinsic min +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + if (ido .eq. 0) then +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = msaup2 +c +c %---------------------------------% +c | Set machine dependent constant. | +c %---------------------------------% +c + eps23 = dlamch('Epsilon-Machine') + eps23 = eps23**(2.0D+0/3.0D+0) +c +c %-------------------------------------% +c | nev0 and np0 are integer variables | +c | hold the initial values of NEV & NP | +c %-------------------------------------% +c + nev0 = nev + np0 = np +c +c %-------------------------------------% +c | kplusp is the bound on the largest | +c | Lanczos factorization built. | +c | nconv is the current number of | +c | "converged" eigenvlues. | +c | iter is the counter on the current | +c | iteration step. | +c %-------------------------------------% +c + kplusp = nev0 + np0 + nconv = 0 + iter = 0 +c +c %--------------------------------------------% +c | Set flags for computing the first NEV steps | +c | of the Lanczos factorization. | +c %--------------------------------------------% +c + getv0 = .true. + update = .false. + ushift = .false. + cnorm = .false. +c + if (info .ne. 0) then +c +c %--------------------------------------------% +c | User provides the initial residual vector. | +c %--------------------------------------------% +c + initv = .true. + info = 0 + else + initv = .false. + end if + end if +c +c %---------------------------------------------% +c | Get a possibly random starting vector and | +c | force it into the range of the operator OP. | +c %---------------------------------------------% +c + 10 continue +c + if (getv0) then + call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, + & ipntr, workd, info) +c + if (ido .ne. 99) go to 9000 +c + if (rnorm .eq. zero) then +c +c %-----------------------------------------% +c | The initial vector is zero. Error exit. | +c %-----------------------------------------% +c + info = -9 + go to 1200 + end if + getv0 = .false. + ido = 0 + end if +c +c %------------------------------------------------------------% +c | Back from reverse communication: continue with update step | +c %------------------------------------------------------------% +c + if (update) go to 20 +c +c %-------------------------------------------% +c | Back from computing user specified shifts | +c %-------------------------------------------% +c + if (ushift) go to 50 +c +c %-------------------------------------% +c | Back from computing residual norm | +c | at the end of the current iteration | +c %-------------------------------------% +c + if (cnorm) go to 100 +c +c %----------------------------------------------------------% +c | Compute the first NEV steps of the Lanczos factorization | +c %----------------------------------------------------------% +c + call dsaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv, + & h, ldh, ipntr, workd, info) +c +c %---------------------------------------------------% +c | ido .ne. 99 implies use of reverse communication | +c | to compute operations involving OP and possibly B | +c %---------------------------------------------------% +c + if (ido .ne. 99) go to 9000 +c + if (info .gt. 0) then +c +c %-----------------------------------------------------% +c | dsaitr was unable to build an Lanczos factorization | +c | of length NEV0. INFO is returned with the size of | +c | the factorization built. Exit main loop. | +c %-----------------------------------------------------% +c + np = info + mxiter = iter + info = -9999 + go to 1200 + end if +c +c %--------------------------------------------------------------% +c | | +c | M A I N LANCZOS I T E R A T I O N L O O P | +c | Each iteration implicitly restarts the Lanczos | +c | factorization in place. | +c | | +c %--------------------------------------------------------------% +c + 1000 continue +c + iter = iter + 1 +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [iter], ndigit, + & '_saup2: **** Start of major iteration number ****') + end if + if (msglvl .gt. 1) then + call ivout (logfil, 1, [nev], ndigit, + & '_saup2: The length of the current Lanczos factorization') + call ivout (logfil, 1, [np], ndigit, + & '_saup2: Extend the Lanczos factorization by') + end if +c +c %------------------------------------------------------------% +c | Compute NP additional steps of the Lanczos factorization. | +c %------------------------------------------------------------% +c + ido = 0 + 20 continue + update = .true. +c + call dsaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v, + & ldv, h, ldh, ipntr, workd, info) +c +c %---------------------------------------------------% +c | ido .ne. 99 implies use of reverse communication | +c | to compute operations involving OP and possibly B | +c %---------------------------------------------------% +c + if (ido .ne. 99) go to 9000 +c + if (info .gt. 0) then +c +c %-----------------------------------------------------% +c | dsaitr was unable to build an Lanczos factorization | +c | of length NEV0+NP0. INFO is returned with the size | +c | of the factorization built. Exit main loop. | +c %-----------------------------------------------------% +c + np = info + mxiter = iter + info = -9999 + go to 1200 + end if + update = .false. +c + if (msglvl .gt. 1) then + call dvout (logfil, 1, [rnorm], ndigit, + & '_saup2: Current B-norm of residual for factorization') + end if +c +c %--------------------------------------------------------% +c | Compute the eigenvalues and corresponding error bounds | +c | of the current symmetric tridiagonal matrix. | +c %--------------------------------------------------------% +c + call dseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) +c + if (ierr .ne. 0) then + info = -8 + go to 1200 + end if +c +c %----------------------------------------------------% +c | Make a copy of eigenvalues and corresponding error | +c | bounds obtained from _seigt. | +c %----------------------------------------------------% +c + call dcopy(kplusp, ritz, 1, workl(kplusp+1), 1) + call dcopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) +c +c %---------------------------------------------------% +c | Select the wanted Ritz values and their bounds | +c | to be used in the convergence test. | +c | The selection is based on the requested number of | +c | eigenvalues instead of the current NEV and NP to | +c | prevent possible misconvergence. | +c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | +c | * Shifts := RITZ(1:NP) := WORKL(1:NP) | +c %---------------------------------------------------% +c + nev = nev0 + np = np0 + call dsgets (ishift, which, nev, np, ritz, bounds, workl) +c +c %-------------------% +c | Convergence test. | +c %-------------------% +c + call dcopy (nev, bounds(np+1), 1, workl(np+1), 1) + call dsconv (nev, ritz(np+1), workl(np+1), tol, nconv) +c + if (msglvl .gt. 2) then + kp(1) = nev + kp(2) = np + kp(3) = nconv + call ivout (logfil, 3, kp, ndigit, + & '_saup2: NEV, NP, NCONV are') + call dvout (logfil, kplusp, ritz, ndigit, + & '_saup2: The eigenvalues of H') + call dvout (logfil, kplusp, bounds, ndigit, + & '_saup2: Ritz estimates of the current NCV Ritz values') + end if +c +c %---------------------------------------------------------% +c | Count the number of unwanted Ritz values that have zero | +c | Ritz estimates. If any Ritz estimates are equal to zero | +c | then a leading block of H of order equal to at least | +c | the number of Ritz values with zero Ritz estimates has | +c | split off. None of these Ritz values may be removed by | +c | shifting. Decrease NP the number of shifts to apply. If | +c | no shifts may be applied, then prepare to exit | +c %---------------------------------------------------------% +c + nptemp = np + do 30 j=1, nptemp + if (bounds(j) .eq. zero) then + np = np - 1 + nev = nev + 1 + end if + 30 continue +c + if ( (nconv .ge. nev0) .or. + & (iter .gt. mxiter) .or. + & (np .eq. 0) ) then +c +c %------------------------------------------------% +c | Prepare to exit. Put the converged Ritz values | +c | and corresponding bounds in RITZ(1:NCONV) and | +c | BOUNDS(1:NCONV) respectively. Then sort. Be | +c | careful when NCONV > NP since we don't want to | +c | swap overlapping locations. | +c %------------------------------------------------% +c + if (which .eq. 'BE') then +c +c %-----------------------------------------------------% +c | Both ends of the spectrum are requested. | +c | Sort the eigenvalues into algebraically decreasing | +c | order first then swap low end of the spectrum next | +c | to high end in appropriate locations. | +c | NOTE: when np < floor(nev/2) be careful not to swap | +c | overlapping locations. | +c %-----------------------------------------------------% +c + wprime = 'SA' + call dsortr (wprime, .true., kplusp, ritz, bounds) + nevd2 = nev0 / 2 + nevm2 = nev0 - nevd2 + if ( nev .gt. 1 ) then + call dswap ( min(nevd2,np), ritz(nevm2+1), 1, + & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1) + call dswap ( min(nevd2,np), bounds(nevm2+1), 1, + & bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1) + end if +c + else +c +c %--------------------------------------------------% +c | LM, SM, LA, SA case. | +c | Sort the eigenvalues of H into the an order that | +c | is opposite to WHICH, and apply the resulting | +c | order to BOUNDS. The eigenvalues are sorted so | +c | that the wanted part are always within the first | +c | NEV locations. | +c %--------------------------------------------------% +c + if (which .eq. 'LM') wprime = 'SM' + if (which .eq. 'SM') wprime = 'LM' + if (which .eq. 'LA') wprime = 'SA' + if (which .eq. 'SA') wprime = 'LA' +c + call dsortr (wprime, .true., kplusp, ritz, bounds) +c + end if +c +c %--------------------------------------------------% +c | Scale the Ritz estimate of each Ritz value | +c | by 1 / max(eps23,magnitude of the Ritz value). | +c %--------------------------------------------------% +c + do 35 j = 1, nev0 + temp = max( eps23, abs(ritz(j)) ) + bounds(j) = bounds(j)/temp + 35 continue +c +c %----------------------------------------------------% +c | Sort the Ritz values according to the scaled Ritz | +c | esitmates. This will push all the converged ones | +c | towards the front of ritzr, ritzi, bounds | +c | (in the case when NCONV < NEV.) | +c %----------------------------------------------------% +c + wprime = 'LA' + call dsortr(wprime, .true., nev0, bounds, ritz) +c +c %----------------------------------------------% +c | Scale the Ritz estimate back to its original | +c | value. | +c %----------------------------------------------% +c + do 40 j = 1, nev0 + temp = max( eps23, abs(ritz(j)) ) + bounds(j) = bounds(j)*temp + 40 continue +c +c %--------------------------------------------------% +c | Sort the "converged" Ritz values again so that | +c | the "threshold" values and their associated Ritz | +c | estimates appear at the appropriate position in | +c | ritz and bound. | +c %--------------------------------------------------% +c + if (which .eq. 'BE') then +c +c %------------------------------------------------% +c | Sort the "converged" Ritz values in increasing | +c | order. The "threshold" values are in the | +c | middle. | +c %------------------------------------------------% +c + wprime = 'LA' + call dsortr(wprime, .true., nconv, ritz, bounds) +c + else +c +c %----------------------------------------------% +c | In LM, SM, LA, SA case, sort the "converged" | +c | Ritz values according to WHICH so that the | +c | "threshold" value appears at the front of | +c | ritz. | +c %----------------------------------------------% + + call dsortr(which, .true., nconv, ritz, bounds) +c + end if +c +c %------------------------------------------% +c | Use h( 1,1 ) as storage to communicate | +c | rnorm to _seupd if needed | +c %------------------------------------------% +c + h(1,1) = rnorm +c + if (msglvl .gt. 1) then + call dvout (logfil, kplusp, ritz, ndigit, + & '_saup2: Sorted Ritz values.') + call dvout (logfil, kplusp, bounds, ndigit, + & '_saup2: Sorted ritz estimates.') + end if +c +c %------------------------------------% +c | Max iterations have been exceeded. | +c %------------------------------------% +c + if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 +c +c %---------------------% +c | No shifts to apply. | +c %---------------------% +c + if (np .eq. 0 .and. nconv .lt. nev0) info = 2 +c + np = nconv + go to 1100 +c + else if (nconv .lt. nev .and. ishift .eq. 1) then +c +c %---------------------------------------------------% +c | Do not have all the requested eigenvalues yet. | +c | To prevent possible stagnation, adjust the number | +c | of Ritz values and the shifts. | +c %---------------------------------------------------% +c + nevbef = nev + nev = nev + min (nconv, np/2) + if (nev .eq. 1 .and. kplusp .ge. 6) then + nev = kplusp / 2 + else if (nev .eq. 1 .and. kplusp .gt. 2) then + nev = 2 + end if + np = kplusp - nev +c +c %---------------------------------------% +c | If the size of NEV was just increased | +c | resort the eigenvalues. | +c %---------------------------------------% +c + if (nevbef .lt. nev) + & call dsgets (ishift, which, nev, np, ritz, bounds, + & workl) +c + end if +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [nconv], ndigit, + & '_saup2: no. of "converged" Ritz values at this iter.') + if (msglvl .gt. 1) then + kp(1) = nev + kp(2) = np + call ivout (logfil, 2, kp, ndigit, + & '_saup2: NEV and NP are') + call dvout (logfil, nev, ritz(np+1), ndigit, + & '_saup2: "wanted" Ritz values.') + call dvout (logfil, nev, bounds(np+1), ndigit, + & '_saup2: Ritz estimates of the "wanted" values ') + end if + end if + +c + if (ishift .eq. 0) then +c +c %-----------------------------------------------------% +c | User specified shifts: reverse communication to | +c | compute the shifts. They are returned in the first | +c | NP locations of WORKL. | +c %-----------------------------------------------------% +c + ushift = .true. + ido = 3 + go to 9000 + end if +c + 50 continue +c +c %------------------------------------% +c | Back from reverse communication; | +c | User specified shifts are returned | +c | in WORKL(1:*NP) | +c %------------------------------------% +c + ushift = .false. +c +c +c %---------------------------------------------------------% +c | Move the NP shifts to the first NP locations of RITZ to | +c | free up WORKL. This is for the non-exact shift case; | +c | in the exact shift case, dsgets already handles this. | +c %---------------------------------------------------------% +c + if (ishift .eq. 0) call dcopy (np, workl, 1, ritz, 1) +c + if (msglvl .gt. 2) then + call ivout (logfil, 1, [np], ndigit, + & '_saup2: The number of shifts to apply ') + call dvout (logfil, np, workl, ndigit, + & '_saup2: shifts selected') + if (ishift .eq. 1) then + call dvout (logfil, np, bounds, ndigit, + & '_saup2: corresponding Ritz estimates') + end if + end if +c +c %---------------------------------------------------------% +c | Apply the NP0 implicit shifts by QR bulge chasing. | +c | Each shift is applied to the entire tridiagonal matrix. | +c | The first 2*N locations of WORKD are used as workspace. | +c | After dsapps is done, we have a Lanczos | +c | factorization of length NEV. | +c %---------------------------------------------------------% +c + call dsapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq, + & workd) +c +c %---------------------------------------------% +c | Compute the B-norm of the updated residual. | +c | Keep B*RESID in WORKD(1:N) to be used in | +c | the first step of the next call to dsaitr. | +c %---------------------------------------------% +c + cnorm = .true. + call arsecond (t2) + if (bmat .eq. 'G') then + nbx = nbx + 1 + call dcopy (n, resid, 1, workd(n+1), 1) + ipntr(1) = n + 1 + ipntr(2) = 1 + ido = 2 +c +c %----------------------------------% +c | Exit in order to compute B*RESID | +c %----------------------------------% +c + go to 9000 + else if (bmat .eq. 'I') then + call dcopy (n, resid, 1, workd, 1) + end if +c + 100 continue +c +c %----------------------------------% +c | Back from reverse communication; | +c | WORKD(1:N) := B*RESID | +c %----------------------------------% +c + if (bmat .eq. 'G') then + call arsecond (t3) + tmvbx = tmvbx + (t3 - t2) + end if +c + if (bmat .eq. 'G') then + rnorm = ddot (n, resid, 1, workd, 1) + rnorm = sqrt(abs(rnorm)) + else if (bmat .eq. 'I') then + rnorm = dnrm2(n, resid, 1) + end if + cnorm = .false. + 130 continue +c + if (msglvl .gt. 2) then + call dvout (logfil, 1, [rnorm], ndigit, + & '_saup2: B-norm of residual for NEV factorization') + call dvout (logfil, nev, h(1,2), ndigit, + & '_saup2: main diagonal of compressed H matrix') + call dvout (logfil, nev-1, h(2,1), ndigit, + & '_saup2: subdiagonal of compressed H matrix') + end if +c + go to 1000 +c +c %---------------------------------------------------------------% +c | | +c | E N D O F M A I N I T E R A T I O N L O O P | +c | | +c %---------------------------------------------------------------% +c + 1100 continue +c + mxiter = iter + nev = nconv +c + 1200 continue + ido = 99 +c +c %------------% +c | Error exit | +c %------------% +c + call arsecond (t1) + tsaup2 = t1 - t0 +c + 9000 continue + return +c +c %---------------% +c | End of dsaup2 | +c %---------------% +c + end diff --git a/src/arpack/dsaupd.f b/src/arpack/dsaupd.f new file mode 100644 index 0000000000..53e300b717 --- /dev/null +++ b/src/arpack/dsaupd.f @@ -0,0 +1,690 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dsaupd +c +c\Description: +c +c Reverse communication interface for the Implicitly Restarted Arnoldi +c Iteration. For symmetric problems this reduces to a variant of the Lanczos +c method. This method has been designed to compute approximations to a +c few eigenpairs of a linear operator OP that is real and symmetric +c with respect to a real positive semi-definite symmetric matrix B, +c i.e. +c +c B*OP = (OP`)*B. +c +c Another way to express this condition is +c +c < x,OPy > = < OPx,y > where < z,w > = z`Bw . +c +c In the standard eigenproblem B is the identity matrix. +c ( A` denotes transpose of A) +c +c The computed approximate eigenvalues are called Ritz values and +c the corresponding approximate eigenvectors are called Ritz vectors. +c +c dsaupd is usually called iteratively to solve one of the +c following problems: +c +c Mode 1: A*x = lambda*x, A symmetric +c ===> OP = A and B = I. +c +c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite +c ===> OP = inv[M]*A and B = M. +c ===> (If M can be factored see remark 3 below) +c +c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite +c ===> OP = (inv[K - sigma*M])*M and B = M. +c ===> Shift-and-Invert mode +c +c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, +c KG symmetric indefinite +c ===> OP = (inv[K - sigma*KG])*K and B = K. +c ===> Buckling mode +c +c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite +c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. +c ===> Cayley transformed mode +c +c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v +c should be accomplished either by a direct method +c using a sparse matrix factorization and solving +c +c [A - sigma*M]*w = v or M*w = v, +c +c or through an iterative method for solving these +c systems. If an iterative method is used, the +c convergence test must be more stringent than +c the accuracy requirements for the eigenvalue +c approximations. +c +c\Usage: +c call dsaupd +c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, +c IPNTR, WORKD, WORKL, LWORKL, INFO ) +c +c\Arguments +c IDO Integer. (INPUT/OUTPUT) +c Reverse communication flag. IDO must be zero on the first +c call to dsaupd . IDO will be set internally to +c indicate the type of operation to be performed. Control is +c then given back to the calling routine which has the +c responsibility to carry out the requested operation and call +c dsaupd with the result. The operand is given in +c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). +c (If Mode = 2 see remark 5 below) +c ------------------------------------------------------------- +c IDO = 0: first call to the reverse communication interface +c IDO = -1: compute Y = OP * X where +c IPNTR(1) is the pointer into WORKD for X, +c IPNTR(2) is the pointer into WORKD for Y. +c This is for the initialization phase to force the +c starting vector into the range of OP. +c IDO = 1: compute Y = OP * X where +c IPNTR(1) is the pointer into WORKD for X, +c IPNTR(2) is the pointer into WORKD for Y. +c In mode 3,4 and 5, the vector B * X is already +c available in WORKD(ipntr(3)). It does not +c need to be recomputed in forming OP * X. +c IDO = 2: compute Y = B * X where +c IPNTR(1) is the pointer into WORKD for X, +c IPNTR(2) is the pointer into WORKD for Y. +c IDO = 3: compute the IPARAM(8) shifts where +c IPNTR(11) is the pointer into WORKL for +c placing the shifts. See remark 6 below. +c IDO = 99: done +c ------------------------------------------------------------- +c +c BMAT Character*1. (INPUT) +c BMAT specifies the type of the matrix B that defines the +c semi-inner product for the operator OP. +c B = 'I' -> standard eigenvalue problem A*x = lambda*x +c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +c +c N Integer. (INPUT) +c Dimension of the eigenproblem. +c +c WHICH Character*2. (INPUT) +c Specify which of the Ritz values of OP to compute. +c +c 'LA' - compute the NEV largest (algebraic) eigenvalues. +c 'SA' - compute the NEV smallest (algebraic) eigenvalues. +c 'LM' - compute the NEV largest (in magnitude) eigenvalues. +c 'SM' - compute the NEV smallest (in magnitude) eigenvalues. +c 'BE' - compute NEV eigenvalues, half from each end of the +c spectrum. When NEV is odd, compute one more from the +c high end than from the low end. +c (see remark 1 below) +c +c NEV Integer. (INPUT) +c Number of eigenvalues of OP to be computed. 0 < NEV < N. +c +c TOL Double precision scalar. (INPUT) +c Stopping criterion: the relative accuracy of the Ritz value +c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). +c If TOL .LE. 0. is passed a default is set: +c DEFAULT = DLAMCH ('EPS') (machine precision as computed +c by the LAPACK auxiliary subroutine DLAMCH ). +c +c RESID Double precision array of length N. (INPUT/OUTPUT) +c On INPUT: +c If INFO .EQ. 0, a random initial residual vector is used. +c If INFO .NE. 0, RESID contains the initial residual vector, +c possibly from a previous run. +c On OUTPUT: +c RESID contains the final residual vector. +c +c NCV Integer. (INPUT) +c Number of columns of the matrix V (less than or equal to N). +c This will indicate how many Lanczos vectors are generated +c at each iteration. After the startup phase in which NEV +c Lanczos vectors are generated, the algorithm generates +c NCV-NEV Lanczos vectors at each subsequent update iteration. +c Most of the cost in generating each Lanczos vector is in the +c matrix-vector product OP*x. (See remark 4 below). +c +c V Double precision N by NCV array. (OUTPUT) +c The NCV columns of V contain the Lanczos basis vectors. +c +c LDV Integer. (INPUT) +c Leading dimension of V exactly as declared in the calling +c program. +c +c IPARAM Integer array of length 11. (INPUT/OUTPUT) +c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. +c The shifts selected at each iteration are used to restart +c the Arnoldi iteration in an implicit fashion. +c ------------------------------------------------------------- +c ISHIFT = 0: the shifts are provided by the user via +c reverse communication. The NCV eigenvalues of +c the current tridiagonal matrix T are returned in +c the part of WORKL array corresponding to RITZ. +c See remark 6 below. +c ISHIFT = 1: exact shifts with respect to the reduced +c tridiagonal matrix T. This is equivalent to +c restarting the iteration with a starting vector +c that is a linear combination of Ritz vectors +c associated with the "wanted" Ritz values. +c ------------------------------------------------------------- +c +c IPARAM(2) = LEVEC +c No longer referenced. See remark 2 below. +c +c IPARAM(3) = MXITER +c On INPUT: maximum number of Arnoldi update iterations allowed. +c On OUTPUT: actual number of Arnoldi update iterations taken. +c +c IPARAM(4) = NB: blocksize to be used in the recurrence. +c The code currently works only for NB = 1. +c +c IPARAM(5) = NCONV: number of "converged" Ritz values. +c This represents the number of Ritz values that satisfy +c the convergence criterion. +c +c IPARAM(6) = IUPD +c No longer referenced. Implicit restarting is ALWAYS used. +c +c IPARAM(7) = MODE +c On INPUT determines what type of eigenproblem is being solved. +c Must be 1,2,3,4,5; See under \Description of dsaupd for the +c five modes available. +c +c IPARAM(8) = NP +c When ido = 3 and the user provides shifts through reverse +c communication (IPARAM(1)=0), dsaupd returns NP, the number +c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark +c 6 below. +c +c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, +c OUTPUT: NUMOP = total number of OP*x operations, +c NUMOPB = total number of B*x operations if BMAT='G', +c NUMREO = total number of steps of re-orthogonalization. +c +c IPNTR Integer array of length 11. (OUTPUT) +c Pointer to mark the starting locations in the WORKD and WORKL +c arrays for matrices/vectors used by the Lanczos iteration. +c ------------------------------------------------------------- +c IPNTR(1): pointer to the current operand vector X in WORKD. +c IPNTR(2): pointer to the current result vector Y in WORKD. +c IPNTR(3): pointer to the vector B * X in WORKD when used in +c the shift-and-invert mode. +c IPNTR(4): pointer to the next available location in WORKL +c that is untouched by the program. +c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL. +c IPNTR(6): pointer to the NCV RITZ values array in WORKL. +c IPNTR(7): pointer to the Ritz estimates in array WORKL associated +c with the Ritz values located in RITZ in WORKL. +c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below. +c +c Note: IPNTR(8:10) is only referenced by dseupd . See Remark 2. +c IPNTR(8): pointer to the NCV RITZ values of the original system. +c IPNTR(9): pointer to the NCV corresponding error bounds. +c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors +c of the tridiagonal matrix T. Only referenced by +c dseupd if RVEC = .TRUE. See Remarks. +c ------------------------------------------------------------- +c +c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +c Distributed array to be used in the basic Arnoldi iteration +c for reverse communication. The user should not use WORKD +c as temporary workspace during the iteration. Upon termination +c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired +c subroutine dseupd uses this output. +c See Data Distribution Note below. +c +c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) +c Private (replicated) array on each PE or array allocated on +c the front end. See Data Distribution Note below. +c +c LWORKL Integer. (INPUT) +c LWORKL must be at least NCV**2 + 8*NCV . +c +c INFO Integer. (INPUT/OUTPUT) +c If INFO .EQ. 0, a randomly initial residual vector is used. +c If INFO .NE. 0, RESID contains the initial residual vector, +c possibly from a previous run. +c Error flag on output. +c = 0: Normal exit. +c = 1: Maximum number of iterations taken. +c All possible eigenvalues of OP has been found. IPARAM(5) +c returns the number of wanted converged Ritz values. +c = 2: No longer an informational error. Deprecated starting +c with release 2 of ARPACK. +c = 3: No shifts could be applied during a cycle of the +c Implicitly restarted Arnoldi iteration. One possibility +c is to increase the size of NCV relative to NEV. +c See remark 4 below. +c = -1: N must be positive. +c = -2: NEV must be positive. +c = -3: NCV must be greater than NEV and less than or equal to N. +c = -4: The maximum number of Arnoldi update iterations allowed +c must be greater than zero. +c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. +c = -6: BMAT must be one of 'I' or 'G'. +c = -7: Length of private work array WORKL is not sufficient. +c = -8: Error return from trid. eigenvalue calculation; +c Informatinal error from LAPACK routine dsteqr . +c = -9: Starting vector is zero. +c = -10: IPARAM(7) must be 1,2,3,4,5. +c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. +c = -12: IPARAM(1) must be equal to 0 or 1. +c = -13: NEV and WHICH = 'BE' are incompatable. +c = -9999: Could not build an Arnoldi factorization. +c IPARAM(5) returns the size of the current Arnoldi +c factorization. The user is advised to check that +c enough workspace and array storage has been allocated. +c +c +c\Remarks +c 1. The converged Ritz values are always returned in ascending +c algebraic order. The computed Ritz values are approximate +c eigenvalues of OP. The selection of WHICH should be made +c with this in mind when Mode = 3,4,5. After convergence, +c approximate eigenvalues of the original problem may be obtained +c with the ARPACK subroutine dseupd . +c +c 2. If the Ritz vectors corresponding to the converged Ritz values +c are needed, the user must call dseupd immediately following completion +c of dsaupd . This is new starting with version 2.1 of ARPACK. +c +c 3. If M can be factored into a Cholesky factorization M = LL` +c then Mode = 2 should not be selected. Instead one should use +c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular +c linear systems should be solved with L and L` rather +c than computing inverses. After convergence, an approximate +c eigenvector z of the original problem is recovered by solving +c L`z = x where x is a Ritz vector of OP. +c +c 4. At present there is no a-priori analysis to guide the selection +c of NCV relative to NEV. The only formal requrement is that NCV > NEV. +c However, it is recommended that NCV .ge. 2*NEV. If many problems of +c the same type are to be solved, one should experiment with increasing +c NCV while keeping NEV fixed for a given test problem. This will +c usually decrease the required number of OP*x operations but it +c also increases the work and storage required to maintain the orthogonal +c basis vectors. The optimal "cross-over" with respect to CPU time +c is problem dependent and must be determined empirically. +c +c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user +c must do the following. When IDO = 1, Y = OP * X is to be computed. +c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user +c must overwrite X with A*X. Y is then the solution to the linear set +c of equations B*Y = A*X. +c +c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the +c NP = IPARAM(8) shifts in locations: +c 1 WORKL(IPNTR(11)) +c 2 WORKL(IPNTR(11)+1) +c . +c . +c . +c NP WORKL(IPNTR(11)+NP-1). +c +c The eigenvalues of the current tridiagonal matrix are located in +c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the +c order defined by WHICH. The associated Ritz estimates are located in +c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). +c +c----------------------------------------------------------------------- +c +c\Data Distribution Note: +c +c Fortran-D syntax: +c ================ +c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL) +c DECOMPOSE D1(N), D2(N,NCV) +c ALIGN RESID(I) with D1(I) +c ALIGN V(I,J) with D2(I,J) +c ALIGN WORKD(I) with D1(I) range (1:N) +c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N) +c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N) +c DISTRIBUTE D1(BLOCK), D2(BLOCK,:) +c REPLICATED WORKL(LWORKL) +c +c Cray MPP syntax: +c =============== +c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL) +c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:) +c REPLICATED WORKL(LWORKL) +c +c +c\BeginLib +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +c Restarted Arnoldi Iteration", Rice University Technical Report +c TR95-13, Department of Computational and Applied Mathematics. +c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, +c 1980. +c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", +c Computer Physics Communications, 53 (1989), pp 169-179. +c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to +c Implement the Spectral Transformation", Math. Comp., 48 (1987), +c pp 663-673. +c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos +c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", +c SIAM J. Matr. Anal. Apps., January (1993). +c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines +c for Updating the QR decomposition", ACM TOMS, December 1990, +c Volume 16 Number 4, pp 369-377. +c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral +c Transformations in a k-Step Arnoldi Method". In Preparation. +c +c\Routines called: +c dsaup2 ARPACK routine that implements the Implicitly Restarted +c Arnoldi Iteration. +c dstats ARPACK routine that initialize timing and other statistics +c variables. +c ivout ARPACK utility routine that prints integers. +c second ARPACK utility routine for timing. +c dvout ARPACK utility routine that prints vectors. +c dlamch LAPACK routine that determines machine constants. +c +c\Authors +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c 12/15/93: Version ' 2.4' +c +c\SCCS Information: @(#) +c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 +c +c\Remarks +c 1. None +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dsaupd + & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, + & ipntr, workd, workl, lworkl, info ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character bmat*1, which*2 + integer ido, info, ldv, lworkl, n, ncv, nev + Double precision + & tol +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + integer iparam(11), ipntr(11) + Double precision + & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0 , zero = 0.0D+0 ) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer bounds, ierr, ih, iq, ishift, iupd, iw, + & ldh, ldq, msglvl, mxiter, mode, nb, + & nev0, next, np, ritz, j + save bounds, ierr, ih, iq, ishift, iupd, iw, + & ldh, ldq, msglvl, mxiter, mode, nb, + & nev0, next, np, ritz +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dsaup2 , dvout , ivout, second, dstats +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dlamch + external dlamch +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + if (ido .eq. 0) then +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call dstats + call arsecond (t0) + msglvl = msaupd +c + ierr = 0 + ishift = iparam(1) + mxiter = iparam(3) +c nb = iparam(4) + nb = 1 +c +c %--------------------------------------------% +c | Revision 2 performs only implicit restart. | +c %--------------------------------------------% +c + iupd = 1 + mode = iparam(7) +c +c %----------------% +c | Error checking | +c %----------------% +c + if (n .le. 0) then + ierr = -1 + else if (nev .le. 0) then + ierr = -2 + else if (ncv .le. nev .or. ncv .gt. n) then + ierr = -3 + end if +c +c %----------------------------------------------% +c | NP is the number of additional steps to | +c | extend the length NEV Lanczos factorization. | +c %----------------------------------------------% +c + np = ncv - nev +c + if (mxiter .le. 0) ierr = -4 + if (which .ne. 'LM' .and. + & which .ne. 'SM' .and. + & which .ne. 'LA' .and. + & which .ne. 'SA' .and. + & which .ne. 'BE') ierr = -5 + if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 +c + if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7 + if (mode .lt. 1 .or. mode .gt. 5) then + ierr = -10 + else if (mode .eq. 1 .and. bmat .eq. 'G') then + ierr = -11 + else if (ishift .lt. 0 .or. ishift .gt. 1) then + ierr = -12 + else if (nev .eq. 1 .and. which .eq. 'BE') then + ierr = -13 + end if +c +c %------------% +c | Error Exit | +c %------------% +c + if (ierr .ne. 0) then + info = ierr + ido = 99 + go to 9000 + end if +c +c %------------------------% +c | Set default parameters | +c %------------------------% +c + if (nb .le. 0) nb = 1 + if (tol .le. zero) tol = dlamch ('EpsMach') +c +c %----------------------------------------------% +c | NP is the number of additional steps to | +c | extend the length NEV Lanczos factorization. | +c | NEV0 is the local variable designating the | +c | size of the invariant subspace desired. | +c %----------------------------------------------% +c + np = ncv - nev + nev0 = nev +c +c %-----------------------------% +c | Zero out internal workspace | +c %-----------------------------% +c + do 10 j = 1, ncv**2 + 8*ncv + workl(j) = zero + 10 continue +c +c %-------------------------------------------------------% +c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +c | etc... and the remaining workspace. | +c | Also update pointer to be used on output. | +c | Memory is laid out as follows: | +c | workl(1:2*ncv) := generated tridiagonal matrix | +c | workl(2*ncv+1:2*ncv+ncv) := ritz values | +c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | +c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | +c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | +c %-------------------------------------------------------% +c + ldh = ncv + ldq = ncv + ih = 1 + ritz = ih + 2*ldh + bounds = ritz + ncv + iq = bounds + ncv + iw = iq + ncv**2 + next = iw + 3*ncv +c + ipntr(4) = next + ipntr(5) = ih + ipntr(6) = ritz + ipntr(7) = bounds + ipntr(11) = iw + end if +c +c %-------------------------------------------------------% +c | Carry out the Implicitly restarted Lanczos Iteration. | +c %-------------------------------------------------------% +c + call dsaup2 + & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, + & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), + & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd, + & info ) +c +c %--------------------------------------------------% +c | ido .ne. 99 implies use of reverse communication | +c | to compute operations involving OP or shifts. | +c %--------------------------------------------------% +c + if (ido .eq. 3) iparam(8) = np + if (ido .ne. 99) go to 9000 +c + iparam(3) = mxiter + iparam(5) = np + iparam(9) = nopx + iparam(10) = nbx + iparam(11) = nrorth +c +c %------------------------------------% +c | Exit if there was an informational | +c | error within dsaup2 . | +c %------------------------------------% +c + if (info .lt. 0) go to 9000 + if (info .eq. 2) info = 3 +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [mxiter], ndigit, + & '_saupd: number of update iterations taken') + call ivout (logfil, 1, [np], ndigit, + & '_saupd: number of "converged" Ritz values') + call dvout (logfil, np, workl(Ritz), ndigit, + & '_saupd: final Ritz values') + call dvout (logfil, np, workl(Bounds), ndigit, + & '_saupd: corresponding error bounds') + end if +c + call arsecond (t1) + tsaupd = t1 - t0 +c + if (msglvl .gt. 0) then +c +c %--------------------------------------------------------% +c | Version Number & Version Date are defined in version.h | +c %--------------------------------------------------------% +c + write (6,1000) + write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, + & tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref, + & tgetv0, tseigt, tsgets, tsapps, tsconv + 1000 format (//, + & 5x, '==========================================',/ + & 5x, '= Symmetric implicit Arnoldi update code =',/ + & 5x, '= Version Number:', ' 2.4' , 19x, ' =',/ + & 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/ + & 5x, '==========================================',/ + & 5x, '= Summary of timing statistics =',/ + & 5x, '==========================================',//) + 1100 format ( + & 5x, 'Total number update iterations = ', i5,/ + & 5x, 'Total number of OP*x operations = ', i5,/ + & 5x, 'Total number of B*x operations = ', i5,/ + & 5x, 'Total number of reorthogonalization steps = ', i5,/ + & 5x, 'Total number of iterative refinement steps = ', i5,/ + & 5x, 'Total number of restart steps = ', i5,/ + & 5x, 'Total time in user OP*x operation = ', f12.6,/ + & 5x, 'Total time in user B*x operation = ', f12.6,/ + & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ + & 5x, 'Total time in saup2 routine = ', f12.6,/ + & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ + & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ + & 5x, 'Total time in (re)start vector generation = ', f12.6,/ + & 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/ + & 5x, 'Total time in getting the shifts = ', f12.6,/ + & 5x, 'Total time in applying the shifts = ', f12.6,/ + & 5x, 'Total time in convergence testing = ', f12.6) + end if +c + 9000 continue +c + return +c +c %---------------% +c | End of dsaupd | +c %---------------% +c + end diff --git a/src/arpack/dsconv.f b/src/arpack/dsconv.f new file mode 100644 index 0000000000..ca84657874 --- /dev/null +++ b/src/arpack/dsconv.f @@ -0,0 +1,138 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dsconv +c +c\Description: +c Convergence testing for the symmetric Arnoldi eigenvalue routine. +c +c\Usage: +c call dsconv +c ( N, RITZ, BOUNDS, TOL, NCONV ) +c +c\Arguments +c N Integer. (INPUT) +c Number of Ritz values to check for convergence. +c +c RITZ Double precision array of length N. (INPUT) +c The Ritz values to be checked for convergence. +c +c BOUNDS Double precision array of length N. (INPUT) +c Ritz estimates associated with the Ritz values in RITZ. +c +c TOL Double precision scalar. (INPUT) +c Desired relative accuracy for a Ritz value to be considered +c "converged". +c +c NCONV Integer scalar. (OUTPUT) +c Number of "converged" Ritz values. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Routines called: +c second ARPACK utility routine for timing. +c dlamch LAPACK routine that determines machine constants. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\SCCS Information: @(#) +c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 +c +c\Remarks +c 1. Starting with version 2.4, this routine no longer uses the +c Parlett strategy using the gap conditions. +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dsconv (n, ritz, bounds, tol, nconv) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + integer n, nconv + Double precision + & tol +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & ritz(n), bounds(n) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer i + Double precision + & temp, eps23 +c +c %-------------------% +c | External routines | +c %-------------------% +c + Double precision + & dlamch + external dlamch + +c %---------------------% +c | Intrinsic Functions | +c %---------------------% +c + intrinsic abs +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + call arsecond (t0) +c + eps23 = dlamch('Epsilon-Machine') + eps23 = eps23**(2.0D+0 / 3.0D+0) +c + nconv = 0 + do 10 i = 1, n +c +c %-----------------------------------------------------% +c | The i-th Ritz value is considered "converged" | +c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | +c %-----------------------------------------------------% +c + temp = max( eps23, abs(ritz(i)) ) + if ( bounds(i) .le. tol*temp ) then + nconv = nconv + 1 + end if +c + 10 continue +c + call arsecond (t1) + tsconv = tsconv + (t1 - t0) +c + return +c +c %---------------% +c | End of dsconv | +c %---------------% +c + end diff --git a/src/arpack/dseigt.f b/src/arpack/dseigt.f new file mode 100644 index 0000000000..a773bece78 --- /dev/null +++ b/src/arpack/dseigt.f @@ -0,0 +1,181 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dseigt +c +c\Description: +c Compute the eigenvalues of the current symmetric tridiagonal matrix +c and the corresponding error bounds given the current residual norm. +c +c\Usage: +c call dseigt +c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR ) +c +c\Arguments +c RNORM Double precision scalar. (INPUT) +c RNORM contains the residual norm corresponding to the current +c symmetric tridiagonal matrix H. +c +c N Integer. (INPUT) +c Size of the symmetric tridiagonal matrix H. +c +c H Double precision N by 2 array. (INPUT) +c H contains the symmetric tridiagonal matrix with the +c subdiagonal in the first column starting at H(2,1) and the +c main diagonal in second column. +c +c LDH Integer. (INPUT) +c Leading dimension of H exactly as declared in the calling +c program. +c +c EIG Double precision array of length N. (OUTPUT) +c On output, EIG contains the N eigenvalues of H possibly +c unsorted. The BOUNDS arrays are returned in the +c same sorted order as EIG. +c +c BOUNDS Double precision array of length N. (OUTPUT) +c On output, BOUNDS contains the error estimates corresponding +c to the eigenvalues EIG. This is equal to RNORM times the +c last components of the eigenvectors corresponding to the +c eigenvalues in EIG. +c +c WORKL Double precision work array of length 3*N. (WORKSPACE) +c Private (replicated) array on each PE or array allocated on +c the front end. +c +c IERR Integer. (OUTPUT) +c Error exit flag from dstqrb. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\Routines called: +c dstqrb ARPACK routine that computes the eigenvalues and the +c last components of the eigenvectors of a symmetric +c and tridiagonal matrix. +c second ARPACK utility routine for timing. +c dvout ARPACK utility routine that prints vectors. +c dcopy Level 1 BLAS that copies one vector to another. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/92: Version ' 2.4' +c +c\SCCS Information: @(#) +c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 +c +c\Remarks +c None +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dseigt + & ( rnorm, n, h, ldh, eig, bounds, workl, ierr ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + integer ierr, ldh, n + Double precision + & rnorm +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & eig(n), bounds(n), h(ldh,2), workl(3*n) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & zero + parameter (zero = 0.0D+0) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer i, k, msglvl +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dcopy, dstqrb, dvout, second +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = mseigt +c + if (msglvl .gt. 0) then + call dvout (logfil, n, h(1,2), ndigit, + & '_seigt: main diagonal of matrix H') + if (n .gt. 1) then + call dvout (logfil, n-1, h(2,1), ndigit, + & '_seigt: sub diagonal of matrix H') + end if + end if +c + call dcopy (n, h(1,2), 1, eig, 1) + call dcopy (n-1, h(2,1), 1, workl, 1) + call dstqrb (n, eig, workl, bounds, workl(n+1), ierr) + if (ierr .ne. 0) go to 9000 + if (msglvl .gt. 1) then + call dvout (logfil, n, bounds, ndigit, + & '_seigt: last row of the eigenvector matrix for H') + end if +c +c %-----------------------------------------------% +c | Finally determine the error bounds associated | +c | with the n Ritz values of H. | +c %-----------------------------------------------% +c + do 30 k = 1, n + bounds(k) = rnorm*abs(bounds(k)) + 30 continue +c + call arsecond (t1) + tseigt = tseigt + (t1 - t0) +c + 9000 continue + return +c +c %---------------% +c | End of dseigt | +c %---------------% +c + end diff --git a/src/arpack/dsesrt.f b/src/arpack/dsesrt.f new file mode 100644 index 0000000000..2b4ca8cbc0 --- /dev/null +++ b/src/arpack/dsesrt.f @@ -0,0 +1,217 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dsesrt +c +c\Description: +c Sort the array X in the order specified by WHICH and optionally +c apply the permutation to the columns of the matrix A. +c +c\Usage: +c call dsesrt +c ( WHICH, APPLY, N, X, NA, A, LDA) +c +c\Arguments +c WHICH Character*2. (Input) +c 'LM' -> X is sorted into increasing order of magnitude. +c 'SM' -> X is sorted into decreasing order of magnitude. +c 'LA' -> X is sorted into increasing order of algebraic. +c 'SA' -> X is sorted into decreasing order of algebraic. +c +c APPLY Logical. (Input) +c APPLY = .TRUE. -> apply the sorted order to A. +c APPLY = .FALSE. -> do not apply the sorted order to A. +c +c N Integer. (INPUT) +c Dimension of the array X. +c +c X Double precision array of length N. (INPUT/OUTPUT) +c The array to be sorted. +c +c NA Integer. (INPUT) +c Number of rows of the matrix A. +c +c A Double precision array of length NA by N. (INPUT/OUTPUT) +c +c LDA Integer. (INPUT) +c Leading dimension of A. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Routines +c dswap Level 1 BLAS that swaps the contents of two vectors. +c +c\Authors +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c 12/15/93: Version ' 2.1'. +c Adapted from the sort routine in LANSO and +c the ARPACK code dsortr +c +c\SCCS Information: @(#) +c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dsesrt (which, apply, n, x, na, a, lda) +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character*2 which + logical apply + integer lda, n, na +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & x(0:n-1), a(lda, 0:n-1) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer i, igap, j + Double precision + & temp +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dswap +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + igap = n / 2 +c + if (which .eq. 'SA') then +c +c X is sorted into decreasing order of algebraic. +c + 10 continue + if (igap .eq. 0) go to 9000 + do 30 i = igap, n-1 + j = i-igap + 20 continue +c + if (j.lt.0) go to 30 +c + if (x(j).lt.x(j+igap)) then + temp = x(j) + x(j) = x(j+igap) + x(j+igap) = temp + if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) + else + go to 30 + endif + j = j-igap + go to 20 + 30 continue + igap = igap / 2 + go to 10 +c + else if (which .eq. 'SM') then +c +c X is sorted into decreasing order of magnitude. +c + 40 continue + if (igap .eq. 0) go to 9000 + do 60 i = igap, n-1 + j = i-igap + 50 continue +c + if (j.lt.0) go to 60 +c + if (abs(x(j)).lt.abs(x(j+igap))) then + temp = x(j) + x(j) = x(j+igap) + x(j+igap) = temp + if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) + else + go to 60 + endif + j = j-igap + go to 50 + 60 continue + igap = igap / 2 + go to 40 +c + else if (which .eq. 'LA') then +c +c X is sorted into increasing order of algebraic. +c + 70 continue + if (igap .eq. 0) go to 9000 + do 90 i = igap, n-1 + j = i-igap + 80 continue +c + if (j.lt.0) go to 90 +c + if (x(j).gt.x(j+igap)) then + temp = x(j) + x(j) = x(j+igap) + x(j+igap) = temp + if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) + else + go to 90 + endif + j = j-igap + go to 80 + 90 continue + igap = igap / 2 + go to 70 +c + else if (which .eq. 'LM') then +c +c X is sorted into increasing order of magnitude. +c + 100 continue + if (igap .eq. 0) go to 9000 + do 120 i = igap, n-1 + j = i-igap + 110 continue +c + if (j.lt.0) go to 120 +c + if (abs(x(j)).gt.abs(x(j+igap))) then + temp = x(j) + x(j) = x(j+igap) + x(j+igap) = temp + if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) + else + go to 120 + endif + j = j-igap + go to 110 + 120 continue + igap = igap / 2 + go to 100 + end if +c + 9000 continue + return +c +c %---------------% +c | End of dsesrt | +c %---------------% +c + end diff --git a/src/arpack/dseupd.f b/src/arpack/dseupd.f new file mode 100644 index 0000000000..5754141e31 --- /dev/null +++ b/src/arpack/dseupd.f @@ -0,0 +1,857 @@ +c\BeginDoc +c +c\Name: dseupd +c +c\Description: +c +c This subroutine returns the converged approximations to eigenvalues +c of A*z = lambda*B*z and (optionally): +c +c (1) the corresponding approximate eigenvectors, +c +c (2) an orthonormal (Lanczos) basis for the associated approximate +c invariant subspace, +c +c (3) Both. +c +c There is negligible additional cost to obtain eigenvectors. An orthonormal +c (Lanczos) basis is always computed. There is an additional storage cost +c of n*nev if both are requested (in this case a separate array Z must be +c supplied). +c +c These quantities are obtained from the Lanczos factorization computed +c by DSAUPD for the linear operator OP prescribed by the MODE selection +c (see IPARAM(7) in DSAUPD documentation.) DSAUPD must be called before +c this routine is called. These approximate eigenvalues and vectors are +c commonly called Ritz values and Ritz vectors respectively. They are +c referred to as such in the comments that follow. The computed orthonormal +c basis for the invariant subspace corresponding to these Ritz values is +c referred to as a Lanczos basis. +c +c See documentation in the header of the subroutine DSAUPD for a definition +c of OP as well as other terms and the relation of computed Ritz values +c and vectors of OP with respect to the given problem A*z = lambda*B*z. +c +c The approximate eigenvalues of the original problem are returned in +c ascending algebraic order. The user may elect to call this routine +c once for each desired Ritz vector and store it peripherally if desired. +c There is also the option of computing a selected set of these vectors +c with a single call. +c +c\Usage: +c call dseupd +c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL, +c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO ) +c +c RVEC LOGICAL (INPUT) +c Specifies whether Ritz vectors corresponding to the Ritz value +c approximations to the eigenproblem A*z = lambda*B*z are computed. +c +c RVEC = .FALSE. Compute Ritz values only. +c +c RVEC = .TRUE. Compute Ritz vectors. +c +c HOWMNY Character*1 (INPUT) +c Specifies how many Ritz vectors are wanted and the form of Z +c the matrix of Ritz vectors. See remark 1 below. +c = 'A': compute NEV Ritz vectors; +c = 'S': compute some of the Ritz vectors, specified +c by the logical array SELECT. +c +c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE) +c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be +c computed. To select the Ritz vector corresponding to a +c Ritz value D(j), SELECT(j) must be set to .TRUE.. +c If HOWMNY = 'A' , SELECT is used as a workspace for +c reordering the Ritz values. +c +c D Double precision array of dimension NEV. (OUTPUT) +c On exit, D contains the Ritz value approximations to the +c eigenvalues of A*z = lambda*B*z. The values are returned +c in ascending order. If IPARAM(7) = 3,4,5 then D represents +c the Ritz values of OP computed by dsaupd transformed to +c those of the original eigensystem A*z = lambda*B*z. If +c IPARAM(7) = 1,2 then the Ritz values of OP are the same +c as the those of A*z = lambda*B*z. +c +c Z Double precision N by NEV array if HOWMNY = 'A'. (OUTPUT) +c On exit, Z contains the B-orthonormal Ritz vectors of the +c eigensystem A*z = lambda*B*z corresponding to the Ritz +c value approximations. +c If RVEC = .FALSE. then Z is not referenced. +c NOTE: The array Z may be set equal to first NEV columns of the +c Arnoldi/Lanczos basis array V computed by DSAUPD . +c +c LDZ Integer. (INPUT) +c The leading dimension of the array Z. If Ritz vectors are +c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. +c +c SIGMA Double precision (INPUT) +c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if +c IPARAM(7) = 1 or 2. +c +c +c **** The remaining arguments MUST be the same as for the **** +c **** call to DSAUPD that was just completed. **** +c +c NOTE: The remaining arguments +c +c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, +c WORKD, WORKL, LWORKL, INFO +c +c must be passed directly to DSEUPD following the last call +c to DSAUPD . These arguments MUST NOT BE MODIFIED between +c the the last call to DSAUPD and the call to DSEUPD . +c +c Two of these parameters (WORKL, INFO) are also output parameters: +c +c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) +c WORKL(1:4*ncv) contains information obtained in +c dsaupd . They are not changed by dseupd . +c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the +c untransformed Ritz values, the computed error estimates, +c and the associated eigenvector matrix of H. +c +c Note: IPNTR(8:10) contains the pointer into WORKL for addresses +c of the above information computed by dseupd . +c ------------------------------------------------------------- +c IPNTR(8): pointer to the NCV RITZ values of the original system. +c IPNTR(9): pointer to the NCV corresponding error bounds. +c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors +c of the tridiagonal matrix T. Only referenced by +c dseupd if RVEC = .TRUE. See Remarks. +c ------------------------------------------------------------- +c +c INFO Integer. (OUTPUT) +c Error flag on output. +c = 0: Normal exit. +c = -1: N must be positive. +c = -2: NEV must be positive. +c = -3: NCV must be greater than NEV and less than or equal to N. +c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. +c = -6: BMAT must be one of 'I' or 'G'. +c = -7: Length of private work WORKL array is not sufficient. +c = -8: Error return from trid. eigenvalue calculation; +c Information error from LAPACK routine dsteqr . +c = -9: Starting vector is zero. +c = -10: IPARAM(7) must be 1,2,3,4,5. +c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +c = -12: NEV and WHICH = 'BE' are incompatible. +c = -14: DSAUPD did not find any eigenvalues to sufficient +c accuracy. +c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true. +c = -16: HOWMNY = 'S' not yet implemented +c = -17: DSEUPD got a different count of the number of converged +c Ritz values than DSAUPD got. This indicates the user +c probably made an error in passing data from DSAUPD to +c DSEUPD or that the data was modified before entering +c DSEUPD . +c +c\BeginLib +c +c\References: +c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +c pp 357-385. +c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +c Restarted Arnoldi Iteration", Rice University Technical Report +c TR95-13, Department of Computational and Applied Mathematics. +c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, +c 1980. +c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", +c Computer Physics Communications, 53 (1989), pp 169-179. +c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to +c Implement the Spectral Transformation", Math. Comp., 48 (1987), +c pp 663-673. +c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos +c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", +c SIAM J. Matr. Anal. Apps., January (1993). +c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines +c for Updating the QR decomposition", ACM TOMS, December 1990, +c Volume 16 Number 4, pp 369-377. +c +c\Remarks +c 1. The converged Ritz values are always returned in increasing +c (algebraic) order. +c +c 2. Currently only HOWMNY = 'A' is implemented. It is included at this +c stage for the user who wants to incorporate it. +c +c\Routines called: +c dsesrt ARPACK routine that sorts an array X, and applies the +c corresponding permutation to a matrix A. +c dsortr dsortr ARPACK sorting routine. +c ivout ARPACK utility routine that prints integers. +c dvout ARPACK utility routine that prints vectors. +c dgeqr2 LAPACK routine that computes the QR factorization of +c a matrix. +c dlacpy LAPACK matrix copy routine. +c dlamch LAPACK routine that determines machine constants. +c dorm2r LAPACK routine that applies an orthogonal matrix in +c factored form. +c dsteqr LAPACK routine that computes eigenvalues and eigenvectors +c of a tridiagonal matrix. +c dger Level 2 BLAS rank one update to a matrix. +c dcopy Level 1 BLAS that copies one vector to another . +c dnrm2 Level 1 BLAS that computes the norm of a vector. +c dscal Level 1 BLAS that scales a vector. +c dswap Level 1 BLAS that swaps the contents of two vectors. + +c\Authors +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Chao Yang Houston, Texas +c Dept. of Computational & +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c 12/15/93: Version ' 2.1' +c +c\SCCS Information: @(#) +c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2 +c +c\EndLib +c +c----------------------------------------------------------------------- + subroutine dseupd (rvec , howmny, select, d , + & z , ldz , sigma , bmat , + & n , which , nev , tol , + & resid , ncv , v , ldv , + & iparam, ipntr , workd , workl, + & lworkl, info ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character bmat, howmny, which*2 + logical rvec + integer info, ldz, ldv, lworkl, n, ncv, nev + Double precision + & sigma, tol +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + integer iparam(7), ipntr(11) + logical select(ncv) + Double precision + & d(nev) , resid(n) , v(ldv,ncv), + & z(ldz, nev), workd(2*n), workl(lworkl) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0 , zero = 0.0D+0 ) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + character type*6 + integer bounds , ierr , ih , ihb , ihd , + & iq , iw , j , k , ldh , + & ldq , mode , msglvl, nconv , next , + & ritz , irz , ibd , np , ishift, + & leftptr, rghtptr, numcnv, jj + Double precision + & bnorm2 , rnorm, temp, temp1, eps23 + logical reord +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dcopy , dger , dgeqr2 , dlacpy , dorm2r , dscal , + & dsesrt , dsteqr , dswap , dvout , ivout , dsortr +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dnrm2 , dlamch + external dnrm2 , dlamch +c +c %---------------------% +c | Intrinsic Functions | +c %---------------------% +c + intrinsic min +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c +c %------------------------% +c | Set default parameters | +c %------------------------% +c + msglvl = mseupd + mode = iparam(7) + nconv = iparam(5) + info = 0 +c +c %--------------% +c | Quick return | +c %--------------% +c + if (nconv .eq. 0) go to 9000 + ierr = 0 +c + if (nconv .le. 0) ierr = -14 + if (n .le. 0) ierr = -1 + if (nev .le. 0) ierr = -2 + if (ncv .le. nev .or. ncv .gt. n) ierr = -3 + if (which .ne. 'LM' .and. + & which .ne. 'SM' .and. + & which .ne. 'LA' .and. + & which .ne. 'SA' .and. + & which .ne. 'BE') ierr = -5 + if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 + if ( (howmny .ne. 'A' .and. + & howmny .ne. 'P' .and. + & howmny .ne. 'S') .and. rvec ) + & ierr = -15 + if (rvec .and. howmny .eq. 'S') ierr = -16 +c + if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7 +c + if (mode .eq. 1 .or. mode .eq. 2) then + type = 'REGULR' + else if (mode .eq. 3 ) then + type = 'SHIFTI' + else if (mode .eq. 4 ) then + type = 'BUCKLE' + else if (mode .eq. 5 ) then + type = 'CAYLEY' + else + ierr = -10 + end if + if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 + if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12 +c +c %------------% +c | Error Exit | +c %------------% +c + if (ierr .ne. 0) then + info = ierr + go to 9000 + end if +c +c %-------------------------------------------------------% +c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +c | etc... and the remaining workspace. | +c | Also update pointer to be used on output. | +c | Memory is laid out as follows: | +c | workl(1:2*ncv) := generated tridiagonal matrix H | +c | The subdiagonal is stored in workl(2:ncv). | +c | The dead spot is workl(1) but upon exiting | +c | dsaupd stores the B-norm of the last residual | +c | vector in workl(1). We use this !!! | +c | workl(2*ncv+1:2*ncv+ncv) := ritz values | +c | The wanted values are in the first NCONV spots. | +c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | +c | The wanted values are in the first NCONV spots. | +c | NOTE: workl(1:4*ncv) is set by dsaupd and is not | +c | modified by dseupd . | +c %-------------------------------------------------------% +c +c %-------------------------------------------------------% +c | The following is used and set by dseupd . | +c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | +c | computation of the eigenvectors of H. Stores | +c | the diagonal of H. Upon EXIT contains the NCV | +c | Ritz values of the original system. The first | +c | NCONV spots have the wanted values. If MODE = | +c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | +c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | +c | computation of the eigenvectors of H. Stores | +c | the subdiagonal of H. Upon EXIT contains the | +c | NCV corresponding Ritz estimates of the | +c | original system. The first NCONV spots have the | +c | wanted values. If MODE = 1,2 then will equal | +c | workl(3*ncv+1:4*ncv). | +c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | +c | the eigenvector matrix for H as returned by | +c | dsteqr . Not referenced if RVEC = .False. | +c | Ordering follows that of workl(4*ncv+1:5*ncv) | +c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | +c | Workspace. Needed by dsteqr and by dseupd . | +c | GRAND total of NCV*(NCV+8) locations. | +c %-------------------------------------------------------% +c +c + ih = ipntr(5) + ritz = ipntr(6) + bounds = ipntr(7) + ldh = ncv + ldq = ncv + ihd = bounds + ldh + ihb = ihd + ldh + iq = ihb + ldh + iw = iq + ldh*ncv + next = iw + 2*ncv + ipntr(4) = next + ipntr(8) = ihd + ipntr(9) = ihb + ipntr(10) = iq +c +c %----------------------------------------% +c | irz points to the Ritz values computed | +c | by _seigt before exiting _saup2. | +c | ibd points to the Ritz estimates | +c | computed by _seigt before exiting | +c | _saup2. | +c %----------------------------------------% +c + irz = ipntr(11)+ncv + ibd = irz+ncv +c +c +c %---------------------------------% +c | Set machine dependent constant. | +c %---------------------------------% +c + eps23 = dlamch ('Epsilon-Machine') + eps23 = eps23**(2.0D+0 / 3.0D+0 ) +c +c %---------------------------------------% +c | RNORM is B-norm of the RESID(1:N). | +c | BNORM2 is the 2 norm of B*RESID(1:N). | +c | Upon exit of dsaupd WORKD(1:N) has | +c | B*RESID(1:N). | +c %---------------------------------------% +c + rnorm = workl(ih) + if (bmat .eq. 'I') then + bnorm2 = rnorm + else if (bmat .eq. 'G') then + bnorm2 = dnrm2 (n, workd, 1) + end if +c + if (msglvl .gt. 2) then + call dvout (logfil, ncv, workl(irz), ndigit, + & '_seupd: Ritz values passed in from _SAUPD.') + call dvout (logfil, ncv, workl(ibd), ndigit, + & '_seupd: Ritz estimates passed in from _SAUPD.') + end if +c + if (rvec) then +c + reord = .false. +c +c %---------------------------------------------------% +c | Use the temporary bounds array to store indices | +c | These will be used to mark the select array later | +c %---------------------------------------------------% +c + do 10 j = 1,ncv + workl(bounds+j-1) = j + select(j) = .false. + 10 continue +c +c %-------------------------------------% +c | Select the wanted Ritz values. | +c | Sort the Ritz values so that the | +c | wanted ones appear at the tailing | +c | NEV positions of workl(irr) and | +c | workl(iri). Move the corresponding | +c | error estimates in workl(bound) | +c | accordingly. | +c %-------------------------------------% +c + np = ncv - nev + ishift = 0 + call dsgets (ishift, which , nev , + & np , workl(irz) , workl(bounds), + & workl) +c + if (msglvl .gt. 2) then + call dvout (logfil, ncv, workl(irz), ndigit, + & '_seupd: Ritz values after calling _SGETS.') + call dvout (logfil, ncv, workl(bounds), ndigit, + & '_seupd: Ritz value indices after calling _SGETS.') + end if +c +c %-----------------------------------------------------% +c | Record indices of the converged wanted Ritz values | +c | Mark the select array for possible reordering | +c %-----------------------------------------------------% +c + numcnv = 0 + do 11 j = 1,ncv + temp1 = max(eps23, abs(workl(irz+ncv-j)) ) + jj = workl(bounds + ncv - j) + if (numcnv .lt. nconv .and. + & workl(ibd+jj-1) .le. tol*temp1) then + select(jj) = .true. + numcnv = numcnv + 1 + if (jj .gt. nev) reord = .true. + endif + 11 continue +c +c %-----------------------------------------------------------% +c | Check the count (numcnv) of converged Ritz values with | +c | the number (nconv) reported by _saupd. If these two | +c | are different then there has probably been an error | +c | caused by incorrect passing of the _saupd data. | +c %-----------------------------------------------------------% +c + if (msglvl .gt. 2) then + call ivout(logfil, 1, [numcnv], ndigit, + & '_seupd: Number of specified eigenvalues') + call ivout(logfil, 1, [nconv], ndigit, + & '_seupd: Number of "converged" eigenvalues') + end if +c + if (numcnv .ne. nconv) then + info = -17 + go to 9000 + end if +c +c %-----------------------------------------------------------% +c | Call LAPACK routine _steqr to compute the eigenvalues and | +c | eigenvectors of the final symmetric tridiagonal matrix H. | +c | Initialize the eigenvector matrix Q to the identity. | +c %-----------------------------------------------------------% +c + call dcopy (ncv-1, workl(ih+1), 1, workl(ihb), 1) + call dcopy (ncv, workl(ih+ldh), 1, workl(ihd), 1) +c + call dsteqr ('Identity', ncv, workl(ihd), workl(ihb), + & workl(iq) , ldq, workl(iw), ierr) +c + if (ierr .ne. 0) then + info = -8 + go to 9000 + end if +c + if (msglvl .gt. 1) then + call dcopy (ncv, workl(iq+ncv-1), ldq, workl(iw), 1) + call dvout (logfil, ncv, workl(ihd), ndigit, + & '_seupd: NCV Ritz values of the final H matrix') + call dvout (logfil, ncv, workl(iw), ndigit, + & '_seupd: last row of the eigenvector matrix for H') + end if +c + if (reord) then +c +c %---------------------------------------------% +c | Reordered the eigenvalues and eigenvectors | +c | computed by _steqr so that the "converged" | +c | eigenvalues appear in the first NCONV | +c | positions of workl(ihd), and the associated | +c | eigenvectors appear in the first NCONV | +c | columns. | +c %---------------------------------------------% +c + leftptr = 1 + rghtptr = ncv +c + if (ncv .eq. 1) go to 30 +c + 20 if (select(leftptr)) then +c +c %-------------------------------------------% +c | Search, from the left, for the first Ritz | +c | value that has not converged. | +c %-------------------------------------------% +c + leftptr = leftptr + 1 +c + else if ( .not. select(rghtptr)) then +c +c %----------------------------------------------% +c | Search, from the right, the first Ritz value | +c | that has converged. | +c %----------------------------------------------% +c + rghtptr = rghtptr - 1 +c + else +c +c %----------------------------------------------% +c | Swap the Ritz value on the left that has not | +c | converged with the Ritz value on the right | +c | that has converged. Swap the associated | +c | eigenvector of the tridiagonal matrix H as | +c | well. | +c %----------------------------------------------% +c + temp = workl(ihd+leftptr-1) + workl(ihd+leftptr-1) = workl(ihd+rghtptr-1) + workl(ihd+rghtptr-1) = temp + call dcopy (ncv, workl(iq+ncv*(leftptr-1)), 1, + & workl(iw), 1) + call dcopy (ncv, workl(iq+ncv*(rghtptr-1)), 1, + & workl(iq+ncv*(leftptr-1)), 1) + call dcopy (ncv, workl(iw), 1, + & workl(iq+ncv*(rghtptr-1)), 1) + leftptr = leftptr + 1 + rghtptr = rghtptr - 1 +c + end if +c + if (leftptr .lt. rghtptr) go to 20 +c + 30 end if +c + if (msglvl .gt. 2) then + call dvout (logfil, ncv, workl(ihd), ndigit, + & '_seupd: The eigenvalues of H--reordered') + end if +c +c %----------------------------------------% +c | Load the converged Ritz values into D. | +c %----------------------------------------% +c + call dcopy (nconv, workl(ihd), 1, d, 1) +c + else +c +c %-----------------------------------------------------% +c | Ritz vectors not required. Load Ritz values into D. | +c %-----------------------------------------------------% +c + call dcopy (nconv, workl(ritz), 1, d, 1) + call dcopy (ncv, workl(ritz), 1, workl(ihd), 1) +c + end if +c +c %------------------------------------------------------------------% +c | Transform the Ritz values and possibly vectors and corresponding | +c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | +c | (and corresponding data) are returned in ascending order. | +c %------------------------------------------------------------------% +c + if (type .eq. 'REGULR') then +c +c %---------------------------------------------------------% +c | Ascending sort of wanted Ritz values, vectors and error | +c | bounds. Not necessary if only Ritz values are desired. | +c %---------------------------------------------------------% +c + if (rvec) then + call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) + else + call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) + end if +c + else +c +c %-------------------------------------------------------------% +c | * Make a copy of all the Ritz values. | +c | * Transform the Ritz values back to the original system. | +c | For TYPE = 'SHIFTI' the transformation is | +c | lambda = 1/theta + sigma | +c | For TYPE = 'BUCKLE' the transformation is | +c | lambda = sigma * theta / ( theta - 1 ) | +c | For TYPE = 'CAYLEY' the transformation is | +c | lambda = sigma * (theta + 1) / (theta - 1 ) | +c | where the theta are the Ritz values returned by dsaupd . | +c | NOTES: | +c | *The Ritz vectors are not affected by the transformation. | +c | They are only reordered. | +c %-------------------------------------------------------------% +c + call dcopy (ncv, workl(ihd), 1, workl(iw), 1) + if (type .eq. 'SHIFTI') then + do 40 k=1, ncv + workl(ihd+k-1) = one / workl(ihd+k-1) + sigma + 40 continue + else if (type .eq. 'BUCKLE') then + do 50 k=1, ncv + workl(ihd+k-1) = sigma * workl(ihd+k-1) / + & (workl(ihd+k-1) - one) + 50 continue + else if (type .eq. 'CAYLEY') then + do 60 k=1, ncv + workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) / + & (workl(ihd+k-1) - one) + 60 continue + end if +c +c %-------------------------------------------------------------% +c | * Store the wanted NCONV lambda values into D. | +c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | +c | into ascending order and apply sort to the NCONV theta | +c | values in the transformed system. We will need this to | +c | compute Ritz estimates in the original system. | +c | * Finally sort the lambda`s into ascending order and apply | +c | to Ritz vectors if wanted. Else just sort lambda`s into | +c | ascending order. | +c | NOTES: | +c | *workl(iw:iw+ncv-1) contain the theta ordered so that they | +c | match the ordering of the lambda. We`ll use them again for | +c | Ritz vector purification. | +c %-------------------------------------------------------------% +c + call dcopy (nconv, workl(ihd), 1, d, 1) + call dsortr ('LA', .true., nconv, workl(ihd), workl(iw)) + if (rvec) then + call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) + else + call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) + call dscal (ncv, bnorm2/rnorm, workl(ihb), 1) + call dsortr ('LA', .true., nconv, d, workl(ihb)) + end if +c + end if +c +c %------------------------------------------------% +c | Compute the Ritz vectors. Transform the wanted | +c | eigenvectors of the symmetric tridiagonal H by | +c | the Lanczos basis matrix V. | +c %------------------------------------------------% +c + if (rvec .and. howmny .eq. 'A') then +c +c %----------------------------------------------------------% +c | Compute the QR factorization of the matrix representing | +c | the wanted invariant subspace located in the first NCONV | +c | columns of workl(iq,ldq). | +c %----------------------------------------------------------% +c + call dgeqr2 (ncv, nconv , workl(iq) , + & ldq, workl(iw+ncv), workl(ihb), + & ierr) +c +c %--------------------------------------------------------% +c | * Postmultiply V by Q. | +c | * Copy the first NCONV columns of VQ into Z. | +c | The N by NCONV matrix Z is now a matrix representation | +c | of the approximate invariant subspace associated with | +c | the Ritz values in workl(ihd). | +c %--------------------------------------------------------% +c + call dorm2r ('Right', 'Notranspose', n , + & ncv , nconv , workl(iq), + & ldq , workl(iw+ncv), v , + & ldv , workd(n+1) , ierr) + call dlacpy ('All', n, nconv, v, ldv, z, ldz) +c +c %-----------------------------------------------------% +c | In order to compute the Ritz estimates for the Ritz | +c | values in both systems, need the last row of the | +c | eigenvector matrix. Remember, it`s in factored form | +c %-----------------------------------------------------% +c + do 65 j = 1, ncv-1 + workl(ihb+j-1) = zero + 65 continue + workl(ihb+ncv-1) = one + call dorm2r ('Left', 'Transpose' , ncv , + & 1 , nconv , workl(iq) , + & ldq , workl(iw+ncv), workl(ihb), + & ncv , temp , ierr) +c + else if (rvec .and. howmny .eq. 'S') then +c +c Not yet implemented. See remark 2 above. +c + end if +c + if (type .eq. 'REGULR' .and. rvec) then +c + do 70 j=1, ncv + workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) ) + 70 continue +c + else if (type .ne. 'REGULR' .and. rvec) then +c +c %-------------------------------------------------% +c | * Determine Ritz estimates of the theta. | +c | If RVEC = .true. then compute Ritz estimates | +c | of the theta. | +c | If RVEC = .false. then copy Ritz estimates | +c | as computed by dsaupd . | +c | * Determine Ritz estimates of the lambda. | +c %-------------------------------------------------% +c + call dscal (ncv, bnorm2, workl(ihb), 1) + if (type .eq. 'SHIFTI') then +c + do 80 k=1, ncv + workl(ihb+k-1) = abs( workl(ihb+k-1) ) + & / workl(iw+k-1)**2 + 80 continue +c + else if (type .eq. 'BUCKLE') then +c + do 90 k=1, ncv + workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) + & / (workl(iw+k-1)-one )**2 + 90 continue +c + else if (type .eq. 'CAYLEY') then +c + do 100 k=1, ncv + workl(ihb+k-1) = abs( workl(ihb+k-1) + & / workl(iw+k-1)*(workl(iw+k-1)-one) ) + 100 continue +c + end if +c + end if +c + if (type .ne. 'REGULR' .and. msglvl .gt. 1) then + call dvout (logfil, nconv, d, ndigit, + & '_seupd: Untransformed converged Ritz values') + call dvout (logfil, nconv, workl(ihb), ndigit, + & '_seupd: Ritz estimates of the untransformed Ritz values') + else if (msglvl .gt. 1) then + call dvout (logfil, nconv, d, ndigit, + & '_seupd: Converged Ritz values') + call dvout (logfil, nconv, workl(ihb), ndigit, + & '_seupd: Associated Ritz estimates') + end if +c +c %-------------------------------------------------% +c | Ritz vector purification step. Formally perform | +c | one of inverse subspace iteration. Only used | +c | for MODE = 3,4,5. See reference 7 | +c %-------------------------------------------------% +c + if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then +c + do 110 k=0, nconv-1 + workl(iw+k) = workl(iq+k*ldq+ncv-1) + & / workl(iw+k) + 110 continue +c + else if (rvec .and. type .eq. 'BUCKLE') then +c + do 120 k=0, nconv-1 + workl(iw+k) = workl(iq+k*ldq+ncv-1) + & / (workl(iw+k)-one) + 120 continue +c + end if +c + if (type .ne. 'REGULR') + & call dger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz) +c + 9000 continue +c + return +c +c %---------------% +c | End of dseupd | +c %---------------% +c + end diff --git a/src/arpack/dsgets.f b/src/arpack/dsgets.f new file mode 100644 index 0000000000..2202de09be --- /dev/null +++ b/src/arpack/dsgets.f @@ -0,0 +1,219 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dsgets +c +c\Description: +c Given the eigenvalues of the symmetric tridiagonal matrix H, +c computes the NP shifts AMU that are zeros of the polynomial of +c degree NP which filters out components of the unwanted eigenvectors +c corresponding to the AMU's based on some given criteria. +c +c NOTE: This is called even in the case of user specified shifts in +c order to sort the eigenvalues, and error bounds of H for later use. +c +c\Usage: +c call dsgets +c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) +c +c\Arguments +c ISHIFT Integer. (INPUT) +c Method for selecting the implicit shifts at each iteration. +c ISHIFT = 0: user specified shifts +c ISHIFT = 1: exact shift with respect to the matrix H. +c +c WHICH Character*2. (INPUT) +c Shift selection criteria. +c 'LM' -> KEV eigenvalues of largest magnitude are retained. +c 'SM' -> KEV eigenvalues of smallest magnitude are retained. +c 'LA' -> KEV eigenvalues of largest value are retained. +c 'SA' -> KEV eigenvalues of smallest value are retained. +c 'BE' -> KEV eigenvalues, half from each end of the spectrum. +c If KEV is odd, compute one more from the high end. +c +c KEV Integer. (INPUT) +c KEV+NP is the size of the matrix H. +c +c NP Integer. (INPUT) +c Number of implicit shifts to be computed. +c +c RITZ Double precision array of length KEV+NP. (INPUT/OUTPUT) +c On INPUT, RITZ contains the eigenvalues of H. +c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues +c are in the first NP locations and the wanted part is in +c the last KEV locations. When exact shifts are selected, the +c unwanted part corresponds to the shifts to be applied. +c +c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) +c Error bounds corresponding to the ordering in RITZ. +c +c SHIFTS Double precision array of length NP. (INPUT/OUTPUT) +c On INPUT: contains the user specified shifts if ISHIFT = 0. +c On OUTPUT: contains the shifts sorted into decreasing order +c of magnitude with respect to the Ritz estimates contained in +c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\Routines called: +c dsortr ARPACK utility sorting routine. +c ivout ARPACK utility routine that prints integers. +c second ARPACK utility routine for timing. +c dvout ARPACK utility routine that prints vectors. +c dcopy Level 1 BLAS that copies one vector to another. +c dswap Level 1 BLAS that swaps the contents of two vectors. +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/93: Version ' 2.1' +c +c\SCCS Information: @(#) +c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 +c +c\Remarks +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dsgets ( ishift, which, kev, np, ritz, bounds, shifts ) +c +c %----------------------------------------------------% +c | Include files for debugging and timing information | +c %----------------------------------------------------% +c + include 'debug.h' + include 'stat.h' +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character*2 which + integer ishift, kev, np +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & bounds(kev+np), ritz(kev+np), shifts(np) +c +c %------------% +c | Parameters | +c %------------% +c + Double precision + & one, zero + parameter (one = 1.0D+0, zero = 0.0D+0) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer kevd2, msglvl +c +c %----------------------% +c | External Subroutines | +c %----------------------% +c + external dswap, dcopy, dsortr, second +c +c %---------------------% +c | Intrinsic Functions | +c %---------------------% +c + intrinsic max, min +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c +c %-------------------------------% +c | Initialize timing statistics | +c | & message level for debugging | +c %-------------------------------% +c + call arsecond (t0) + msglvl = msgets +c + if (which .eq. 'BE') then +c +c %-----------------------------------------------------% +c | Both ends of the spectrum are requested. | +c | Sort the eigenvalues into algebraically increasing | +c | order first then swap high end of the spectrum next | +c | to low end in appropriate locations. | +c | NOTE: when np < floor(kev/2) be careful not to swap | +c | overlapping locations. | +c %-----------------------------------------------------% +c + call dsortr ('LA', .true., kev+np, ritz, bounds) + kevd2 = kev / 2 + if ( kev .gt. 1 ) then + call dswap ( min(kevd2,np), ritz, 1, + & ritz( max(kevd2,np)+1 ), 1) + call dswap ( min(kevd2,np), bounds, 1, + & bounds( max(kevd2,np)+1 ), 1) + end if +c + else +c +c %----------------------------------------------------% +c | LM, SM, LA, SA case. | +c | Sort the eigenvalues of H into the desired order | +c | and apply the resulting order to BOUNDS. | +c | The eigenvalues are sorted so that the wanted part | +c | are always in the last KEV locations. | +c %----------------------------------------------------% +c + call dsortr (which, .true., kev+np, ritz, bounds) + end if +c + if (ishift .eq. 1 .and. np .gt. 0) then +c +c %-------------------------------------------------------% +c | Sort the unwanted Ritz values used as shifts so that | +c | the ones with largest Ritz estimates are first. | +c | This will tend to minimize the effects of the | +c | forward instability of the iteration when the shifts | +c | are applied in subroutine dsapps. | +c %-------------------------------------------------------% +c + call dsortr ('SM', .true., np, bounds, ritz) + call dcopy (np, ritz, 1, shifts, 1) + end if +c + call arsecond (t1) + tsgets = tsgets + (t1 - t0) +c + if (msglvl .gt. 0) then + call ivout (logfil, 1, [kev], ndigit, '_sgets: KEV is') + call ivout (logfil, 1, [np], ndigit, '_sgets: NP is') + call dvout (logfil, kev+np, ritz, ndigit, + & '_sgets: Eigenvalues of current H matrix') + call dvout (logfil, kev+np, bounds, ndigit, + & '_sgets: Associated Ritz estimates') + end if +c + return +c +c %---------------% +c | End of dsgets | +c %---------------% +c + end diff --git a/src/arpack/dsortc.f b/src/arpack/dsortc.f new file mode 100644 index 0000000000..91af30f8ae --- /dev/null +++ b/src/arpack/dsortc.f @@ -0,0 +1,344 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dsortc +c +c\Description: +c Sorts the complex array in XREAL and XIMAG into the order +c specified by WHICH and optionally applies the permutation to the +c real array Y. It is assumed that if an element of XIMAG is +c nonzero, then its negative is also an element. In other words, +c both members of a complex conjugate pair are to be sorted and the +c pairs are kept adjacent to each other. +c +c\Usage: +c call dsortc +c ( WHICH, APPLY, N, XREAL, XIMAG, Y ) +c +c\Arguments +c WHICH Character*2. (Input) +c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude. +c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude. +c 'LR' -> sort XREAL into increasing order of algebraic. +c 'SR' -> sort XREAL into decreasing order of algebraic. +c 'LI' -> sort XIMAG into increasing order of magnitude. +c 'SI' -> sort XIMAG into decreasing order of magnitude. +c NOTE: If an element of XIMAG is non-zero, then its negative +c is also an element. +c +c APPLY Logical. (Input) +c APPLY = .TRUE. -> apply the sorted order to array Y. +c APPLY = .FALSE. -> do not apply the sorted order to array Y. +c +c N Integer. (INPUT) +c Size of the arrays. +c +c XREAL, Double precision array of length N. (INPUT/OUTPUT) +c XIMAG Real and imaginary part of the array to be sorted. +c +c Y Double precision array of length N. (INPUT/OUTPUT) +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c xx/xx/92: Version ' 2.1' +c Adapted from the sort routine in LANSO. +c +c\SCCS Information: @(#) +c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dsortc (which, apply, n, xreal, ximag, y) +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character*2 which + logical apply + integer n +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & xreal(0:n-1), ximag(0:n-1), y(0:n-1) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer i, igap, j + Double precision + & temp, temp1, temp2 +c +c %--------------------% +c | External Functions | +c %--------------------% +c + Double precision + & dlapy2 + external dlapy2 +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + igap = n / 2 +c + if (which .eq. 'LM') then +c +c %------------------------------------------------------% +c | Sort XREAL,XIMAG into increasing order of magnitude. | +c %------------------------------------------------------% +c + 10 continue + if (igap .eq. 0) go to 9000 +c + do 30 i = igap, n-1 + j = i-igap + 20 continue +c + if (j.lt.0) go to 30 +c + temp1 = dlapy2(xreal(j),ximag(j)) + temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) +c + if (temp1.gt.temp2) then + temp = xreal(j) + xreal(j) = xreal(j+igap) + xreal(j+igap) = temp +c + temp = ximag(j) + ximag(j) = ximag(j+igap) + ximag(j+igap) = temp +c + if (apply) then + temp = y(j) + y(j) = y(j+igap) + y(j+igap) = temp + end if + else + go to 30 + end if + j = j-igap + go to 20 + 30 continue + igap = igap / 2 + go to 10 +c + else if (which .eq. 'SM') then +c +c %------------------------------------------------------% +c | Sort XREAL,XIMAG into decreasing order of magnitude. | +c %------------------------------------------------------% +c + 40 continue + if (igap .eq. 0) go to 9000 +c + do 60 i = igap, n-1 + j = i-igap + 50 continue +c + if (j .lt. 0) go to 60 +c + temp1 = dlapy2(xreal(j),ximag(j)) + temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) +c + if (temp1.lt.temp2) then + temp = xreal(j) + xreal(j) = xreal(j+igap) + xreal(j+igap) = temp +c + temp = ximag(j) + ximag(j) = ximag(j+igap) + ximag(j+igap) = temp +c + if (apply) then + temp = y(j) + y(j) = y(j+igap) + y(j+igap) = temp + end if + else + go to 60 + endif + j = j-igap + go to 50 + 60 continue + igap = igap / 2 + go to 40 +c + else if (which .eq. 'LR') then +c +c %------------------------------------------------% +c | Sort XREAL into increasing order of algebraic. | +c %------------------------------------------------% +c + 70 continue + if (igap .eq. 0) go to 9000 +c + do 90 i = igap, n-1 + j = i-igap + 80 continue +c + if (j.lt.0) go to 90 +c + if (xreal(j).gt.xreal(j+igap)) then + temp = xreal(j) + xreal(j) = xreal(j+igap) + xreal(j+igap) = temp +c + temp = ximag(j) + ximag(j) = ximag(j+igap) + ximag(j+igap) = temp +c + if (apply) then + temp = y(j) + y(j) = y(j+igap) + y(j+igap) = temp + end if + else + go to 90 + endif + j = j-igap + go to 80 + 90 continue + igap = igap / 2 + go to 70 +c + else if (which .eq. 'SR') then +c +c %------------------------------------------------% +c | Sort XREAL into decreasing order of algebraic. | +c %------------------------------------------------% +c + 100 continue + if (igap .eq. 0) go to 9000 + do 120 i = igap, n-1 + j = i-igap + 110 continue +c + if (j.lt.0) go to 120 +c + if (xreal(j).lt.xreal(j+igap)) then + temp = xreal(j) + xreal(j) = xreal(j+igap) + xreal(j+igap) = temp +c + temp = ximag(j) + ximag(j) = ximag(j+igap) + ximag(j+igap) = temp +c + if (apply) then + temp = y(j) + y(j) = y(j+igap) + y(j+igap) = temp + end if + else + go to 120 + endif + j = j-igap + go to 110 + 120 continue + igap = igap / 2 + go to 100 +c + else if (which .eq. 'LI') then +c +c %------------------------------------------------% +c | Sort XIMAG into increasing order of magnitude. | +c %------------------------------------------------% +c + 130 continue + if (igap .eq. 0) go to 9000 + do 150 i = igap, n-1 + j = i-igap + 140 continue +c + if (j.lt.0) go to 150 +c + if (abs(ximag(j)).gt.abs(ximag(j+igap))) then + temp = xreal(j) + xreal(j) = xreal(j+igap) + xreal(j+igap) = temp +c + temp = ximag(j) + ximag(j) = ximag(j+igap) + ximag(j+igap) = temp +c + if (apply) then + temp = y(j) + y(j) = y(j+igap) + y(j+igap) = temp + end if + else + go to 150 + endif + j = j-igap + go to 140 + 150 continue + igap = igap / 2 + go to 130 +c + else if (which .eq. 'SI') then +c +c %------------------------------------------------% +c | Sort XIMAG into decreasing order of magnitude. | +c %------------------------------------------------% +c + 160 continue + if (igap .eq. 0) go to 9000 + do 180 i = igap, n-1 + j = i-igap + 170 continue +c + if (j.lt.0) go to 180 +c + if (abs(ximag(j)).lt.abs(ximag(j+igap))) then + temp = xreal(j) + xreal(j) = xreal(j+igap) + xreal(j+igap) = temp +c + temp = ximag(j) + ximag(j) = ximag(j+igap) + ximag(j+igap) = temp +c + if (apply) then + temp = y(j) + y(j) = y(j+igap) + y(j+igap) = temp + end if + else + go to 180 + endif + j = j-igap + go to 170 + 180 continue + igap = igap / 2 + go to 160 + end if +c + 9000 continue + return +c +c %---------------% +c | End of dsortc | +c %---------------% +c + end diff --git a/src/arpack/dsortr.f b/src/arpack/dsortr.f new file mode 100644 index 0000000000..3903b81c5a --- /dev/null +++ b/src/arpack/dsortr.f @@ -0,0 +1,218 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dsortr +c +c\Description: +c Sort the array X1 in the order specified by WHICH and optionally +c applies the permutation to the array X2. +c +c\Usage: +c call dsortr +c ( WHICH, APPLY, N, X1, X2 ) +c +c\Arguments +c WHICH Character*2. (Input) +c 'LM' -> X1 is sorted into increasing order of magnitude. +c 'SM' -> X1 is sorted into decreasing order of magnitude. +c 'LA' -> X1 is sorted into increasing order of algebraic. +c 'SA' -> X1 is sorted into decreasing order of algebraic. +c +c APPLY Logical. (Input) +c APPLY = .TRUE. -> apply the sorted order to X2. +c APPLY = .FALSE. -> do not apply the sorted order to X2. +c +c N Integer. (INPUT) +c Size of the arrays. +c +c X1 Double precision array of length N. (INPUT/OUTPUT) +c The array to be sorted. +c +c X2 Double precision array of length N. (INPUT/OUTPUT) +c Only referenced if APPLY = .TRUE. +c +c\EndDoc +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\Revision history: +c 12/16/93: Version ' 2.1'. +c Adapted from the sort routine in LANSO. +c +c\SCCS Information: @(#) +c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dsortr (which, apply, n, x1, x2) +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + character*2 which + logical apply + integer n +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & x1(0:n-1), x2(0:n-1) +c +c %---------------% +c | Local Scalars | +c %---------------% +c + integer i, igap, j + Double precision + & temp +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + igap = n / 2 +c + if (which .eq. 'SA') then +c +c X1 is sorted into decreasing order of algebraic. +c + 10 continue + if (igap .eq. 0) go to 9000 + do 30 i = igap, n-1 + j = i-igap + 20 continue +c + if (j.lt.0) go to 30 +c + if (x1(j).lt.x1(j+igap)) then + temp = x1(j) + x1(j) = x1(j+igap) + x1(j+igap) = temp + if (apply) then + temp = x2(j) + x2(j) = x2(j+igap) + x2(j+igap) = temp + end if + else + go to 30 + endif + j = j-igap + go to 20 + 30 continue + igap = igap / 2 + go to 10 +c + else if (which .eq. 'SM') then +c +c X1 is sorted into decreasing order of magnitude. +c + 40 continue + if (igap .eq. 0) go to 9000 + do 60 i = igap, n-1 + j = i-igap + 50 continue +c + if (j.lt.0) go to 60 +c + if (abs(x1(j)).lt.abs(x1(j+igap))) then + temp = x1(j) + x1(j) = x1(j+igap) + x1(j+igap) = temp + if (apply) then + temp = x2(j) + x2(j) = x2(j+igap) + x2(j+igap) = temp + end if + else + go to 60 + endif + j = j-igap + go to 50 + 60 continue + igap = igap / 2 + go to 40 +c + else if (which .eq. 'LA') then +c +c X1 is sorted into increasing order of algebraic. +c + 70 continue + if (igap .eq. 0) go to 9000 + do 90 i = igap, n-1 + j = i-igap + 80 continue +c + if (j.lt.0) go to 90 +c + if (x1(j).gt.x1(j+igap)) then + temp = x1(j) + x1(j) = x1(j+igap) + x1(j+igap) = temp + if (apply) then + temp = x2(j) + x2(j) = x2(j+igap) + x2(j+igap) = temp + end if + else + go to 90 + endif + j = j-igap + go to 80 + 90 continue + igap = igap / 2 + go to 70 +c + else if (which .eq. 'LM') then +c +c X1 is sorted into increasing order of magnitude. +c + 100 continue + if (igap .eq. 0) go to 9000 + do 120 i = igap, n-1 + j = i-igap + 110 continue +c + if (j.lt.0) go to 120 +c + if (abs(x1(j)).gt.abs(x1(j+igap))) then + temp = x1(j) + x1(j) = x1(j+igap) + x1(j+igap) = temp + if (apply) then + temp = x2(j) + x2(j) = x2(j+igap) + x2(j+igap) = temp + end if + else + go to 120 + endif + j = j-igap + go to 110 + 120 continue + igap = igap / 2 + go to 100 + end if +c + 9000 continue + return +c +c %---------------% +c | End of dsortr | +c %---------------% +c + end diff --git a/src/arpack/dstatn.f b/src/arpack/dstatn.f new file mode 100644 index 0000000000..244df1ae79 --- /dev/null +++ b/src/arpack/dstatn.f @@ -0,0 +1,61 @@ +c +c %---------------------------------------------% +c | Initialize statistic and timing information | +c | for nonsymmetric Arnoldi code. | +c %---------------------------------------------% +c +c\Author +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\SCCS Information: @(#) +c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2 +c + subroutine dstatn +c +c %--------------------------------% +c | See stat.doc for documentation | +c %--------------------------------% +c + include 'stat.h' +c +c %-----------------------% +c | Executable Statements | +c %-----------------------% +c + nopx = 0 + nbx = 0 + nrorth = 0 + nitref = 0 + nrstrt = 0 +c + tnaupd = 0.0D+0 + tnaup2 = 0.0D+0 + tnaitr = 0.0D+0 + tneigh = 0.0D+0 + tngets = 0.0D+0 + tnapps = 0.0D+0 + tnconv = 0.0D+0 + titref = 0.0D+0 + tgetv0 = 0.0D+0 + trvec = 0.0D+0 +c +c %----------------------------------------------------% +c | User time including reverse communication overhead | +c %----------------------------------------------------% +c + tmvopx = 0.0D+0 + tmvbx = 0.0D+0 +c + return +c +c +c %---------------% +c | End of dstatn | +c %---------------% +c + end diff --git a/src/arpack/dstats.f b/src/arpack/dstats.f new file mode 100644 index 0000000000..84f74b473a --- /dev/null +++ b/src/arpack/dstats.f @@ -0,0 +1,47 @@ +c +c\SCCS Information: @(#) +c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2 +c %---------------------------------------------% +c | Initialize statistic and timing information | +c | for symmetric Arnoldi code. | +c %---------------------------------------------% + + subroutine dstats + +c %--------------------------------% +c | See stat.doc for documentation | +c %--------------------------------% + include 'stat.h' + +c %-----------------------% +c | Executable Statements | +c %-----------------------% + + nopx = 0 + nbx = 0 + nrorth = 0 + nitref = 0 + nrstrt = 0 + + tsaupd = 0.0D+0 + tsaup2 = 0.0D+0 + tsaitr = 0.0D+0 + tseigt = 0.0D+0 + tsgets = 0.0D+0 + tsapps = 0.0D+0 + tsconv = 0.0D+0 + titref = 0.0D+0 + tgetv0 = 0.0D+0 + trvec = 0.0D+0 + +c %----------------------------------------------------% +c | User time including reverse communication overhead | +c %----------------------------------------------------% + tmvopx = 0.0D+0 + tmvbx = 0.0D+0 + + return +c +c End of dstats +c + end diff --git a/src/arpack/dstqrb.f b/src/arpack/dstqrb.f new file mode 100644 index 0000000000..9fef543ba7 --- /dev/null +++ b/src/arpack/dstqrb.f @@ -0,0 +1,594 @@ +c----------------------------------------------------------------------- +c\BeginDoc +c +c\Name: dstqrb +c +c\Description: +c Computes all eigenvalues and the last component of the eigenvectors +c of a symmetric tridiagonal matrix using the implicit QL or QR method. +c +c This is mostly a modification of the LAPACK routine dsteqr. +c See Remarks. +c +c\Usage: +c call dstqrb +c ( N, D, E, Z, WORK, INFO ) +c +c\Arguments +c N Integer. (INPUT) +c The number of rows and columns in the matrix. N >= 0. +c +c D Double precision array, dimension (N). (INPUT/OUTPUT) +c On entry, D contains the diagonal elements of the +c tridiagonal matrix. +c On exit, D contains the eigenvalues, in ascending order. +c If an error exit is made, the eigenvalues are correct +c for indices 1,2,...,INFO-1, but they are unordered and +c may not be the smallest eigenvalues of the matrix. +c +c E Double precision array, dimension (N-1). (INPUT/OUTPUT) +c On entry, E contains the subdiagonal elements of the +c tridiagonal matrix in positions 1 through N-1. +c On exit, E has been destroyed. +c +c Z Double precision array, dimension (N). (OUTPUT) +c On exit, Z contains the last row of the orthonormal +c eigenvector matrix of the symmetric tridiagonal matrix. +c If an error exit is made, Z contains the last row of the +c eigenvector matrix associated with the stored eigenvalues. +c +c WORK Double precision array, dimension (max(1,2*N-2)). (WORKSPACE) +c Workspace used in accumulating the transformation for +c computing the last components of the eigenvectors. +c +c INFO Integer. (OUTPUT) +c = 0: normal return. +c < 0: if INFO = -i, the i-th argument had an illegal value. +c > 0: if INFO = +i, the i-th eigenvalue has not converged +c after a total of 30*N iterations. +c +c\Remarks +c 1. None. +c +c----------------------------------------------------------------------- +c +c\BeginLib +c +c\Local variables: +c xxxxxx real +c +c\Routines called: +c daxpy Level 1 BLAS that computes a vector triad. +c dcopy Level 1 BLAS that copies one vector to another. +c dswap Level 1 BLAS that swaps the contents of two vectors. +c lsame LAPACK character comparison routine. +c dlae2 LAPACK routine that computes the eigenvalues of a 2-by-2 +c symmetric matrix. +c dlaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric +c matrix. +c dlamch LAPACK routine that determines machine constants. +c dlanst LAPACK routine that computes the norm of a matrix. +c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +c dlartg LAPACK Givens rotation construction routine. +c dlascl LAPACK routine for careful scaling of a matrix. +c dlaset LAPACK matrix initialization routine. +c dlasr LAPACK routine that applies an orthogonal transformation to +c a matrix. +c dlasrt LAPACK sorting routine. +c dsteqr LAPACK routine that computes eigenvalues and eigenvectors +c of a symmetric tridiagonal matrix. +c xerbla LAPACK error handler routine. +c +c\Authors +c Danny Sorensen Phuong Vu +c Richard Lehoucq CRPC / Rice University +c Dept. of Computational & Houston, Texas +c Applied Mathematics +c Rice University +c Houston, Texas +c +c\SCCS Information: @(#) +c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2 +c +c\Remarks +c 1. Starting with version 2.5, this routine is a modified version +c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted, +c only commeted out and new lines inserted. +c All lines commented out have "c$$$" at the beginning. +c Note that the LAPACK version 1.0 subroutine SSTEQR contained +c bugs. +c +c\EndLib +c +c----------------------------------------------------------------------- +c + subroutine dstqrb ( n, d, e, z, work, info ) +c +c %------------------% +c | Scalar Arguments | +c %------------------% +c + integer info, n +c +c %-----------------% +c | Array Arguments | +c %-----------------% +c + Double precision + & d( n ), e( n-1 ), z( n ), work( 2*n-2 ) +c +c .. parameters .. + Double precision + & zero, one, two, three + parameter ( zero = 0.0D+0, one = 1.0D+0, + & two = 2.0D+0, three = 3.0D+0 ) + integer maxit + parameter ( maxit = 30 ) +c .. +c .. local scalars .. + integer i, icompz, ii, iscale, j, jtot, k, l, l1, lend, + & lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1, + & nm1, nmaxit + Double precision + & anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, + & s, safmax, safmin, ssfmax, ssfmin, tst +c .. +c .. external functions .. + logical lsame + Double precision + & dlamch, dlanst, dlapy2 + external lsame, dlamch, dlanst, dlapy2 +c .. +c .. external subroutines .. + external dlae2, dlaev2, dlartg, dlascl, dlaset, dlasr, + & dlasrt, dswap, xerbla +c .. +c .. intrinsic functions .. + intrinsic abs, max, sign, sqrt +c .. +c .. executable statements .. +c +c test the input parameters. +c + info = 0 +c +c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN +c$$$ ICOMPZ = 0 +c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN +c$$$ ICOMPZ = 1 +c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN +c$$$ ICOMPZ = 2 +c$$$ ELSE +c$$$ ICOMPZ = -1 +c$$$ END IF +c$$$ IF( ICOMPZ.LT.0 ) THEN +c$$$ INFO = -1 +c$$$ ELSE IF( N.LT.0 ) THEN +c$$$ INFO = -2 +c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, +c$$$ $ N ) ) ) THEN +c$$$ INFO = -6 +c$$$ END IF +c$$$ IF( INFO.NE.0 ) THEN +c$$$ CALL XERBLA( 'SSTEQR', -INFO ) +c$$$ RETURN +c$$$ END IF +c +c *** New starting with version 2.5 *** +c + icompz = 2 +c ************************************* +c +c quick return if possible +c + if( n.eq.0 ) + $ return +c + if( n.eq.1 ) then + if( icompz.eq.2 ) z( 1 ) = one + return + end if +c +c determine the unit roundoff and over/underflow thresholds. +c + eps = dlamch( 'e' ) + eps2 = eps**2 + safmin = dlamch( 's' ) + safmax = one / safmin + ssfmax = sqrt( safmax ) / three + ssfmin = sqrt( safmin ) / eps2 +c +c compute the eigenvalues and eigenvectors of the tridiagonal +c matrix. +c +c$$ if( icompz.eq.2 ) +c$$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) +c +c *** New starting with version 2.5 *** +c + if ( icompz .eq. 2 ) then + do 5 j = 1, n-1 + z(j) = zero + 5 continue + z( n ) = one + end if +c ************************************* +c + nmaxit = n*maxit + jtot = 0 +c +c determine where the matrix splits and choose ql or qr iteration +c for each block, according to whether top or bottom diagonal +c element is smaller. +c + l1 = 1 + nm1 = n - 1 +c + 10 continue + if( l1.gt.n ) + $ go to 160 + if( l1.gt.1 ) + $ e( l1-1 ) = zero + if( l1.le.nm1 ) then + do 20 m = l1, nm1 + tst = abs( e( m ) ) + if( tst.eq.zero ) + $ go to 30 + if( tst.le.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+ + $ 1 ) ) ) )*eps ) then + e( m ) = zero + go to 30 + end if + 20 continue + end if + m = n +c + 30 continue + l = l1 + lsv = l + lend = m + lendsv = lend + l1 = m + 1 + if( lend.eq.l ) + $ go to 10 +c +c scale submatrix in rows and columns l to lend +c + anorm = dlanst( 'i', lend-l+1, d( l ), e( l ) ) + iscale = 0 + if( anorm.eq.zero ) + $ go to 10 + if( anorm.gt.ssfmax ) then + iscale = 1 + call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n, + $ info ) + call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n, + $ info ) + else if( anorm.lt.ssfmin ) then + iscale = 2 + call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n, + $ info ) + call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n, + $ info ) + end if +c +c choose between ql and qr iteration +c + if( abs( d( lend ) ).lt.abs( d( l ) ) ) then + lend = lsv + l = lendsv + end if +c + if( lend.gt.l ) then +c +c ql iteration +c +c look for small subdiagonal element. +c + 40 continue + if( l.ne.lend ) then + lendm1 = lend - 1 + do 50 m = l, lendm1 + tst = abs( e( m ) )**2 + if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+ + $ safmin )go to 60 + 50 continue + end if +c + m = lend +c + 60 continue + if( m.lt.lend ) + $ e( m ) = zero + p = d( l ) + if( m.eq.l ) + $ go to 80 +c +c if remaining matrix is 2-by-2, use dlae2 or dlaev2 +c to compute its eigensystem. +c + if( m.eq.l+1 ) then + if( icompz.gt.0 ) then + call dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) + work( l ) = c + work( n-1+l ) = s +c$$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), +c$$$ $ work( n-1+l ), z( 1, l ), ldz ) +c +c *** New starting with version 2.5 *** +c + tst = z(l+1) + z(l+1) = c*tst - s*z(l) + z(l) = s*tst + c*z(l) +c ************************************* + else + call dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) + end if + d( l ) = rt1 + d( l+1 ) = rt2 + e( l ) = zero + l = l + 2 + if( l.le.lend ) + $ go to 40 + go to 140 + end if +c + if( jtot.eq.nmaxit ) + $ go to 140 + jtot = jtot + 1 +c +c form shift. +c + g = ( d( l+1 )-p ) / ( two*e( l ) ) + r = dlapy2( g, one ) + g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) +c + s = one + c = one + p = zero +c +c inner loop +c + mm1 = m - 1 + do 70 i = mm1, l, -1 + f = s*e( i ) + b = c*e( i ) + call dlartg( g, f, c, s, r ) + if( i.ne.m-1 ) + $ e( i+1 ) = r + g = d( i+1 ) - p + r = ( d( i )-g )*s + two*c*b + p = s*r + d( i+1 ) = g + p + g = c*r - b +c +c if eigenvectors are desired, then save rotations. +c + if( icompz.gt.0 ) then + work( i ) = c + work( n-1+i ) = -s + end if +c + 70 continue +c +c if eigenvectors are desired, then apply saved rotations. +c + if( icompz.gt.0 ) then + mm = m - l + 1 +c$$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), +c$$$ $ z( 1, l ), ldz ) +c +c *** New starting with version 2.5 *** +c + call dlasr( 'r', 'v', 'b', 1, mm, work( l ), + & work( n-1+l ), z( l ), 1 ) +c ************************************* + end if +c + d( l ) = d( l ) - p + e( l ) = g + go to 40 +c +c eigenvalue found. +c + 80 continue + d( l ) = p +c + l = l + 1 + if( l.le.lend ) + $ go to 40 + go to 140 +c + else +c +c qr iteration +c +c look for small superdiagonal element. +c + 90 continue + if( l.ne.lend ) then + lendp1 = lend + 1 + do 100 m = l, lendp1, -1 + tst = abs( e( m-1 ) )**2 + if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+ + $ safmin )go to 110 + 100 continue + end if +c + m = lend +c + 110 continue + if( m.gt.lend ) + $ e( m-1 ) = zero + p = d( l ) + if( m.eq.l ) + $ go to 130 +c +c if remaining matrix is 2-by-2, use dlae2 or dlaev2 +c to compute its eigensystem. +c + if( m.eq.l-1 ) then + if( icompz.gt.0 ) then + call dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) +c$$$ work( m ) = c +c$$$ work( n-1+m ) = s +c$$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), +c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) +c +c *** New starting with version 2.5 *** +c + tst = z(l) + z(l) = c*tst - s*z(l-1) + z(l-1) = s*tst + c*z(l-1) +c ************************************* + else + call dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) + end if + d( l-1 ) = rt1 + d( l ) = rt2 + e( l-1 ) = zero + l = l - 2 + if( l.ge.lend ) + $ go to 90 + go to 140 + end if +c + if( jtot.eq.nmaxit ) + $ go to 140 + jtot = jtot + 1 +c +c form shift. +c + g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) + r = dlapy2( g, one ) + g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) +c + s = one + c = one + p = zero +c +c inner loop +c + lm1 = l - 1 + do 120 i = m, lm1 + f = s*e( i ) + b = c*e( i ) + call dlartg( g, f, c, s, r ) + if( i.ne.m ) + $ e( i-1 ) = r + g = d( i ) - p + r = ( d( i+1 )-g )*s + two*c*b + p = s*r + d( i ) = g + p + g = c*r - b +c +c if eigenvectors are desired, then save rotations. +c + if( icompz.gt.0 ) then + work( i ) = c + work( n-1+i ) = s + end if +c + 120 continue +c +c if eigenvectors are desired, then apply saved rotations. +c + if( icompz.gt.0 ) then + mm = l - m + 1 +c$$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), +c$$$ $ z( 1, m ), ldz ) +c +c *** New starting with version 2.5 *** +c + call dlasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ), + & z( m ), 1 ) +c ************************************* + end if +c + d( l ) = d( l ) - p + e( lm1 ) = g + go to 90 +c +c eigenvalue found. +c + 130 continue + d( l ) = p +c + l = l - 1 + if( l.ge.lend ) + $ go to 90 + go to 140 +c + end if +c +c undo scaling if necessary +c + 140 continue + if( iscale.eq.1 ) then + call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1, + $ d( lsv ), n, info ) + call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ), + $ n, info ) + else if( iscale.eq.2 ) then + call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1, + $ d( lsv ), n, info ) + call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ), + $ n, info ) + end if +c +c check for no convergence to an eigenvalue after a total +c of n*maxit iterations. +c + if( jtot.lt.nmaxit ) + $ go to 10 + do 150 i = 1, n - 1 + if( e( i ).ne.zero ) + $ info = info + 1 + 150 continue + go to 190 +c +c order eigenvalues and eigenvectors. +c + 160 continue + if( icompz.eq.0 ) then +c +c use quick sort +c + call dlasrt( 'i', n, d, info ) +c + else +c +c use selection sort to minimize swaps of eigenvectors +c + do 180 ii = 2, n + i = ii - 1 + k = i + p = d( i ) + do 170 j = ii, n + if( d( j ).lt.p ) then + k = j + p = d( j ) + end if + 170 continue + if( k.ne.i ) then + d( k ) = d( i ) + d( i ) = p +c$$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) +c *** New starting with version 2.5 *** +c + p = z(k) + z(k) = z(i) + z(i) = p +c ************************************* + end if + 180 continue + end if +c + 190 continue + return +c +c %---------------% +c | End of dstqrb | +c %---------------% +c + end diff --git a/src/arpack/dvout.f b/src/arpack/dvout.f new file mode 100644 index 0000000000..4138e52c6f --- /dev/null +++ b/src/arpack/dvout.f @@ -0,0 +1,122 @@ +*----------------------------------------------------------------------- +* Routine: DVOUT +* +* Purpose: Real vector output routine. +* +* Usage: CALL DVOUT (LOUT, N, SX, IDIGIT, IFMT) +* +* Arguments +* N - Length of array SX. (Input) +* SX - Real array to be printed. (Input) +* IFMT - Format to be used in printing array SX. (Input) +* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +* If IDIGIT .LT. 0, printing is done with 72 columns. +* If IDIGIT .GT. 0, printing is done with 132 columns. +* +*----------------------------------------------------------------------- +* + SUBROUTINE DVOUT( LOUT, N, SX, IDIGIT, IFMT ) +* ... +* ... SPECIFICATIONS FOR ARGUMENTS +* ... +* ... SPECIFICATIONS FOR LOCAL VARIABLES +* .. Scalar Arguments .. + CHARACTER*( * ) IFMT + INTEGER IDIGIT, LOUT, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SX( * ) +* .. +* .. Local Scalars .. + CHARACTER*80 LINE + INTEGER I, K1, K2, LLL, NDIGIT +* .. +* .. Intrinsic Functions .. + INTRINSIC LEN, MIN, MIN0 +* .. +* .. Executable Statements .. +* ... +* ... FIRST EXECUTABLE STATEMENT +* +* + LLL = MIN( LEN( IFMT ), 80 ) + DO 10 I = 1, LLL + LINE( I: I ) = '-' + 10 CONTINUE +* + DO 20 I = LLL + 1, 80 + LINE( I: I ) = ' ' + 20 CONTINUE +* + WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) + 9999 FORMAT( / 1X, A, / 1X, A ) +* + IF( N.LE.0 ) + $ RETURN + NDIGIT = IDIGIT + IF( IDIGIT.EQ.0 ) + $ NDIGIT = 4 +* +*======================================================================= +* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +*======================================================================= +* + IF( IDIGIT.LT.0 ) THEN + NDIGIT = -IDIGIT + IF( NDIGIT.LE.4 ) THEN + DO 30 K1 = 1, N, 5 + K2 = MIN0( N, K1+4 ) + WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) + 30 CONTINUE + ELSE IF( NDIGIT.LE.6 ) THEN + DO 40 K1 = 1, N, 4 + K2 = MIN0( N, K1+3 ) + WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) + 40 CONTINUE + ELSE IF( NDIGIT.LE.10 ) THEN + DO 50 K1 = 1, N, 3 + K2 = MIN0( N, K1+2 ) + WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) + 50 CONTINUE + ELSE + DO 60 K1 = 1, N, 2 + K2 = MIN0( N, K1+1 ) + WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) + 60 CONTINUE + END IF +* +*======================================================================= +* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +*======================================================================= +* + ELSE + IF( NDIGIT.LE.4 ) THEN + DO 70 K1 = 1, N, 10 + K2 = MIN0( N, K1+9 ) + WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) + 70 CONTINUE + ELSE IF( NDIGIT.LE.6 ) THEN + DO 80 K1 = 1, N, 8 + K2 = MIN0( N, K1+7 ) + WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) + 80 CONTINUE + ELSE IF( NDIGIT.LE.10 ) THEN + DO 90 K1 = 1, N, 6 + K2 = MIN0( N, K1+5 ) + WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) + 90 CONTINUE + ELSE + DO 100 K1 = 1, N, 5 + K2 = MIN0( N, K1+4 ) + WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) + 100 CONTINUE + END IF + END IF + WRITE( LOUT, FMT = 9994 ) + RETURN + 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P, 10D12.3 ) + 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 8D14.5 ) + 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 6D18.9 ) + 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 5D24.13 ) + 9994 FORMAT( 1X, ' ' ) + END diff --git a/src/arpack/icnteq.f b/src/arpack/icnteq.f new file mode 100644 index 0000000000..dc345f9bad --- /dev/null +++ b/src/arpack/icnteq.f @@ -0,0 +1,18 @@ +c +c----------------------------------------------------------------------- +c +c Count the number of elements equal to a specified integer value. +c + integer function icnteq (n, array, value) +c + integer n, value + integer array(*) +c + k = 0 + do 10 i = 1, n + if (array(i) .eq. value) k = k + 1 + 10 continue + icnteq = k +c + return + end diff --git a/src/arpack/icopy.f b/src/arpack/icopy.f new file mode 100644 index 0000000000..f9e8c11003 --- /dev/null +++ b/src/arpack/icopy.f @@ -0,0 +1,77 @@ +*-------------------------------------------------------------------- +*\Documentation +* +*\Name: ICOPY +* +*\Description: +* ICOPY copies an integer vector lx to an integer vector ly. +* +*\Usage: +* call icopy ( n, lx, inc, ly, incy ) +* +*\Arguments: +* n integer (input) +* On entry, n is the number of elements of lx to be +c copied to ly. +* +* lx integer array (input) +* On entry, lx is the integer vector to be copied. +* +* incx integer (input) +* On entry, incx is the increment between elements of lx. +* +* ly integer array (input) +* On exit, ly is the integer vector that contains the +* copy of lx. +* +* incy integer (input) +* On entry, incy is the increment between elements of ly. +* +*\Enddoc +* +*-------------------------------------------------------------------- +* + subroutine icopy( n, lx, incx, ly, incy ) +* +* ---------------------------- +* Specifications for arguments +* ---------------------------- + integer incx, incy, n + integer lx( 1 ), ly( 1 ) +* +* ---------------------------------- +* Specifications for local variables +* ---------------------------------- + integer i, ix, iy +* +* -------------------------- +* First executable statement +* -------------------------- + if( n.le.0 ) + $ return + if( incx.eq.1 .and. incy.eq.1 ) + $ go to 20 +c +c.....code for unequal increments or equal increments +c not equal to 1 + ix = 1 + iy = 1 + if( incx.lt.0 ) + $ ix = ( -n+1 )*incx + 1 + if( incy.lt.0 ) + $ iy = ( -n+1 )*incy + 1 + do 10 i = 1, n + ly( iy ) = lx( ix ) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c.....code for both increments equal to 1 +c + 20 continue + do 30 i = 1, n + ly( i ) = lx( i ) + 30 continue + return + end diff --git a/src/arpack/iset.f b/src/arpack/iset.f new file mode 100644 index 0000000000..cb690bc3e9 --- /dev/null +++ b/src/arpack/iset.f @@ -0,0 +1,16 @@ +c +c----------------------------------------------------------------------- +c +c Only work with increment equal to 1 right now. +c + subroutine iset (n, value, array, inc) +c + integer n, value, inc + integer array(*) +c + do 10 i = 1, n + array(i) = value + 10 continue +c + return + end diff --git a/src/arpack/iswap.f b/src/arpack/iswap.f new file mode 100644 index 0000000000..088798d007 --- /dev/null +++ b/src/arpack/iswap.f @@ -0,0 +1,55 @@ + subroutine iswap (n,sx,incx,sy,incy) +c +c interchanges two vectors. +c uses unrolled loops for increments equal to 1. +c jack dongarra, linpack, 3/11/78. +c + integer sx(1),sy(1),stemp + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal +c to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + stemp = sx(ix) + sx(ix) = sy(iy) + sy(iy) = stemp + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,3) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + stemp = sx(i) + sx(i) = sy(i) + sy(i) = stemp + 30 continue + if( n .lt. 3 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,3 + stemp = sx(i) + sx(i) = sy(i) + sy(i) = stemp + stemp = sx(i + 1) + sx(i + 1) = sy(i + 1) + sy(i + 1) = stemp + stemp = sx(i + 2) + sx(i + 2) = sy(i + 2) + sy(i + 2) = stemp + 50 continue + return + end diff --git a/src/arpack/ivout.f b/src/arpack/ivout.f new file mode 100644 index 0000000000..e97118a86b --- /dev/null +++ b/src/arpack/ivout.f @@ -0,0 +1,120 @@ +C----------------------------------------------------------------------- +C Routine: IVOUT +C +C Purpose: Integer vector output routine. +C +C Usage: CALL IVOUT (LOUT, N, IX, IDIGIT, IFMT) +C +C Arguments +C N - Length of array IX. (Input) +C IX - Integer array to be printed. (Input) +C IFMT - Format to be used in printing array IX. (Input) +C IDIGIT - Print up to ABS(IDIGIT) decimal digits / number. (Input) +C If IDIGIT .LT. 0, printing is done with 72 columns. +C If IDIGIT .GT. 0, printing is done with 132 columns. +C +C----------------------------------------------------------------------- +C + SUBROUTINE IVOUT (LOUT, N, IX, IDIGIT, IFMT) +C ... +C ... SPECIFICATIONS FOR ARGUMENTS + INTEGER IX(*), N, IDIGIT, LOUT + CHARACTER IFMT*(*) +C ... +C ... SPECIFICATIONS FOR LOCAL VARIABLES + INTEGER I, NDIGIT, K1, K2, LLL + CHARACTER*80 LINE +* ... +* ... SPECIFICATIONS INTRINSICS + INTRINSIC MIN +* +C + LLL = MIN ( LEN ( IFMT ), 80 ) + DO 1 I = 1, LLL + LINE(I:I) = '-' + 1 CONTINUE +C + DO 2 I = LLL+1, 80 + LINE(I:I) = ' ' + 2 CONTINUE +C + WRITE ( LOUT, 2000 ) IFMT, LINE(1:LLL) + 2000 FORMAT ( /1X, A /1X, A ) +C + IF (N .LE. 0) RETURN + NDIGIT = IDIGIT + IF (IDIGIT .EQ. 0) NDIGIT = 4 +C +C======================================================================= +C CODE FOR OUTPUT USING 72 COLUMNS FORMAT +C======================================================================= +C + IF (IDIGIT .LT. 0) THEN +C + NDIGIT = -IDIGIT + IF (NDIGIT .LE. 4) THEN + DO 10 K1 = 1, N, 10 + K2 = MIN0(N,K1+9) + WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) + 10 CONTINUE +C + ELSE IF (NDIGIT .LE. 6) THEN + DO 30 K1 = 1, N, 7 + K2 = MIN0(N,K1+6) + WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) + 30 CONTINUE +C + ELSE IF (NDIGIT .LE. 10) THEN + DO 50 K1 = 1, N, 5 + K2 = MIN0(N,K1+4) + WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) + 50 CONTINUE +C + ELSE + DO 70 K1 = 1, N, 3 + K2 = MIN0(N,K1+2) + WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) + 70 CONTINUE + END IF +C +C======================================================================= +C CODE FOR OUTPUT USING 132 COLUMNS FORMAT +C======================================================================= +C + ELSE +C + IF (NDIGIT .LE. 4) THEN + DO 90 K1 = 1, N, 20 + K2 = MIN0(N,K1+19) + WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) + 90 CONTINUE +C + ELSE IF (NDIGIT .LE. 6) THEN + DO 110 K1 = 1, N, 15 + K2 = MIN0(N,K1+14) + WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) + 110 CONTINUE +C + ELSE IF (NDIGIT .LE. 10) THEN + DO 130 K1 = 1, N, 10 + K2 = MIN0(N,K1+9) + WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) + 130 CONTINUE +C + ELSE + DO 150 K1 = 1, N, 7 + K2 = MIN0(N,K1+6) + WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) + 150 CONTINUE + END IF + END IF + WRITE (LOUT,1004) +C + 1000 FORMAT(1X,I4,' - ',I4,':',20(1X,I5)) + 1001 FORMAT(1X,I4,' - ',I4,':',15(1X,I7)) + 1002 FORMAT(1X,I4,' - ',I4,':',10(1X,I11)) + 1003 FORMAT(1X,I4,' - ',I4,':',7(1X,I15)) + 1004 FORMAT(1X,' ') +C + RETURN + END diff --git a/src/arpack/stat.h b/src/arpack/stat.h new file mode 100644 index 0000000000..66a8e9f87f --- /dev/null +++ b/src/arpack/stat.h @@ -0,0 +1,21 @@ +c %--------------------------------% +c | See stat.doc for documentation | +c %--------------------------------% +c +c\SCCS Information: @(#) +c FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 +c + real t0, t1, t2, t3, t4, t5 + save t0, t1, t2, t3, t4, t5 +c + integer nopx, nbx, nrorth, nitref, nrstrt + real tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, + & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, + & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, + & tmvopx, tmvbx, tgetv0, titref, trvec + common /timing/ + & nopx, nbx, nrorth, nitref, nrstrt, + & tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, + & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, + & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, + & tmvopx, tmvbx, tgetv0, titref, trvec diff --git a/src/arpack/version.h b/src/arpack/version.h new file mode 100644 index 0000000000..ecdd9b3405 --- /dev/null +++ b/src/arpack/version.h @@ -0,0 +1,30 @@ +/* + + In the current version, the parameter KAPPA in the Kahan's test + for orthogonality is set to 0.717, the same as used by Gragg & Reichel. + However computational experience indicates that this is a little too + strict and will frequently force reorthogonalization when it is not + necessary to do so. + + Also the "moving boundary" idea is not currently activated in the nonsymmetric + code since it is not conclusive that it's the right thing to do all the time. + Requires further investigation. + + As of 02/01/93 Richard Lehoucq assumes software control of the codes from + Phuong Vu. On 03/01/93 all the *.F files were migrated SCCS. The 1.1 version + of codes are those received from Phuong Vu. The frozen version of 07/08/92 + is now considered version 1.1. + + Version 2.1 contains two new symmetric routines, sesrt and seupd. + Changes as well as bug fixes for version 1.1 codes that were only corrected + for programming bugs are version 1.2. These 1.2 versions will also be in version 2.1. + Subroutine [d,s]saupd now requires slightly more workspace. See [d,s]saupd for the + details. + + \SCCS Information: @(#) + FILE: version.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 + + */ + +#define VERSION_NUMBER ' 2.1' +#define VERSION_DATE ' 11/15/95' diff --git a/src/cpptrajdepend b/src/cpptrajdepend index ad0715b6fc..19d6a4d748 100644 --- a/src/cpptrajdepend +++ b/src/cpptrajdepend @@ -27,7 +27,7 @@ Action_Dihedral.o : Action_Dihedral.cpp Action.h ActionState.h Action_Dihedral.h Action_Dipole.o : Action_Dipole.cpp Action.h ActionState.h Action_Dipole.h ArgList.h ArrayIterator.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h Constants.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_3D.h DataSet_Coords.h DataSet_Coords_REF.h DataSet_GridFlt.h Dimension.h DispatchObject.h FileIO.h FileName.h FileTypes.h Frame.h Grid.h GridAction.h GridBin.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReferenceFrame.h ReplicaDimArray.h Residue.h TextFormat.h Timer.h Topology.h Vec3.h Action_Distance.o : Action_Distance.cpp Action.h ActionState.h Action_Distance.h ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h DistRoutines.h FileIO.h FileName.h FileTypes.h Frame.h ImagedAction.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReferenceFrame.h ReplicaDimArray.h Residue.h TextFormat.h Timer.h Topology.h Vec3.h Action_DistRmsd.o : Action_DistRmsd.cpp Action.h ActionState.h Action_DistRmsd.h ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h FileIO.h FileName.h FileTypes.h Frame.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReferenceAction.h ReferenceFrame.h ReplicaDimArray.h Residue.h TextFormat.h Timer.h Topology.h Vec3.h -Action_Energy.o : Action_Energy.cpp Action.h ActionState.h Action_Energy.h ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h Energy.h Ewald.h FileIO.h FileName.h FileTypes.h Frame.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h PairList.h Parallel.h ParameterTypes.h Range.h ReferenceFrame.h ReplicaDimArray.h Residue.h TextFormat.h Timer.h Topology.h Vec3.h +Action_Energy.o : Action_Energy.cpp Action.h ActionState.h Action_Energy.h ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h Energy.h Ewald.h Ewald_ParticleMesh.h Ewald_Regular.h FileIO.h FileName.h FileTypes.h Frame.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h PairList.h Parallel.h ParameterTypes.h Range.h ReferenceFrame.h ReplicaDimArray.h Residue.h TextFormat.h Timer.h Topology.h Vec3.h Action_FilterByData.o : Action_FilterByData.cpp Action.h ActionState.h Action_FilterByData.h ArgList.h Array1D.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_1D.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h FileIO.h FileName.h FileTypes.h Frame.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReferenceFrame.h ReplicaDimArray.h Residue.h TextFormat.h Timer.h Topology.h Vec3.h Action_FixAtomOrder.o : Action_FixAtomOrder.cpp Action.h ActionState.h Action_FixAtomOrder.h ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h FileIO.h FileName.h FileTypes.h Frame.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h Parallel.h ParameterTypes.h ParmFile.h ParmIO.h Range.h ReferenceFrame.h ReplicaDimArray.h Residue.h TextFormat.h Timer.h Topology.h Vec3.h Action_FixImagedBonds.o : Action_FixImagedBonds.cpp Action.h ActionState.h Action_FixImagedBonds.h ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h DistRoutines.h FileIO.h FileName.h FileTypes.h Frame.h ImagedAction.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReferenceFrame.h ReplicaDimArray.h Residue.h TextFormat.h Timer.h Topology.h Vec3.h @@ -215,7 +215,7 @@ Deprecated.o : Deprecated.cpp CpptrajStdio.h Deprecated.h DispatchObject.h DihedralSearch.o : DihedralSearch.cpp ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataSet.h DihedralSearch.h Dimension.h FileIO.h FileName.h Frame.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h Residue.h TextFormat.h Topology.h Vec3.h DispatchObject.o : DispatchObject.cpp DispatchObject.h DistRoutines.o : DistRoutines.cpp Box.h DistRoutines.h Matrix_3x3.h Parallel.h Vec3.h -Energy.o : Energy.cpp Atom.h AtomExtra.h AtomMask.h Box.h CharMask.h Constants.h CoordinateInfo.h CpptrajStdio.h DistRoutines.h Energy.h FileName.h Frame.h MaskToken.h Matrix_3x3.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h Residue.h Timer.h Topology.h TorsionRoutines.h Vec3.h +Energy.o : Energy.cpp Atom.h AtomExtra.h AtomMask.h Box.h CharMask.h Constants.h CoordinateInfo.h CpptrajStdio.h DistRoutines.h Energy.h FileName.h Frame.h MaskToken.h Matrix_3x3.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h Residue.h Topology.h TorsionRoutines.h Vec3.h EnsembleIn.o : EnsembleIn.cpp ArgList.h Atom.h AtomExtra.h AtomMask.h Box.h CharMask.h CoordinateInfo.h CpptrajStdio.h EnsembleIn.h FileName.h Frame.h FrameArray.h FramePtrArray.h InputTrajCommon.h MaskToken.h Matrix_3x3.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h ReplicaInfo.h Residue.h Timer.h Topology.h TrajFrameCounter.h Vec3.h EnsembleIn_Multi.o : EnsembleIn_Multi.cpp ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h DataFile.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h DataSet_RemLog.h Dimension.h EnsembleIn.h EnsembleIn_Multi.h FileIO.h FileName.h FileTypes.h Frame.h FrameArray.h FramePtrArray.h InputTrajCommon.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReferenceFrame.h ReplicaDimArray.h ReplicaInfo.h Residue.h StringRoutines.h TextFormat.h Timer.h Topology.h TrajFrameCounter.h TrajIOarray.h TrajectoryIO.h Vec3.h EnsembleIn_Single.o : EnsembleIn_Single.cpp ArgList.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h EnsembleIn.h EnsembleIn_Single.h FileIO.h FileName.h FileTypes.h Frame.h FrameArray.h FramePtrArray.h InputTrajCommon.h MaskToken.h Matrix_3x3.h Molecule.h NameType.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h ReplicaInfo.h Residue.h Timer.h Topology.h TrajFrameCounter.h TrajectoryFile.h TrajectoryIO.h Vec3.h @@ -225,6 +225,8 @@ EnsembleOut_Multi.o : EnsembleOut_Multi.cpp ActionFrameCounter.h ArgList.h Atom. EnsembleOut_Single.o : EnsembleOut_Single.cpp ActionFrameCounter.h ArgList.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h EnsembleOut.h EnsembleOut_Single.h FileIO.h FileName.h FileTypes.h Frame.h FrameArray.h FramePtrArray.h MaskToken.h Matrix_3x3.h Molecule.h NameType.h OutputTrajCommon.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h Residue.h Topology.h TrajectoryFile.h TrajectoryIO.h Vec3.h EnsembleOutList.o : EnsembleOutList.cpp ActionFrameCounter.h ArgList.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajStdio.h EnsembleOut.h EnsembleOutList.h EnsembleOut_Multi.h EnsembleOut_Single.h FileIO.h FileName.h FileTypes.h Frame.h FrameArray.h FramePtrArray.h MaskToken.h Matrix_3x3.h Molecule.h NameType.h OutputTrajCommon.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h Residue.h Topology.h TrajectoryFile.h TrajectoryIO.h Vec3.h Ewald.o : Ewald.cpp Atom.h AtomExtra.h AtomMask.h Box.h CharMask.h Constants.h CoordinateInfo.h CpptrajStdio.h Ewald.h FileName.h Frame.h MaskToken.h Matrix_3x3.h Molecule.h NameType.h PairList.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h Residue.h Spline.h StringRoutines.h Timer.h Topology.h Vec3.h +Ewald_ParticleMesh.o : Ewald_ParticleMesh.cpp Atom.h AtomExtra.h AtomMask.h Box.h CharMask.h CoordinateInfo.h CpptrajStdio.h Ewald.h Ewald_ParticleMesh.h FileName.h Frame.h MaskToken.h Matrix_3x3.h Molecule.h NameType.h PairList.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h Residue.h Timer.h Topology.h Vec3.h libpme_standalone.h +Ewald_Regular.o : Ewald_Regular.cpp Atom.h AtomExtra.h AtomMask.h Box.h CharMask.h Constants.h CoordinateInfo.h CpptrajStdio.h Ewald.h Ewald_Regular.h FileName.h Frame.h MaskToken.h Matrix_3x3.h Molecule.h NameType.h PairList.h Parallel.h ParameterTypes.h Range.h ReplicaDimArray.h Residue.h StringRoutines.h Timer.h Topology.h Vec3.h Exec_Analyze.o : Exec_Analyze.cpp Action.h ActionFrameCounter.h ActionList.h ActionState.h Analysis.h AnalysisList.h AnalysisState.h ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h Cmd.h CmdList.h Command.h Control.h CoordinateInfo.h CpptrajFile.h CpptrajState.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h EnsembleIn.h EnsembleOut.h EnsembleOutList.h Exec.h Exec_Analyze.h FileIO.h FileName.h FileTypes.h Frame.h FrameArray.h FramePtrArray.h InputTrajCommon.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h OutputTrajCommon.h Parallel.h ParameterTypes.h Range.h ReferenceFrame.h ReplicaDimArray.h ReplicaInfo.h Residue.h TextFormat.h Timer.h Topology.h TrajFrameCounter.h TrajectoryFile.h TrajectoryIO.h Trajin.h TrajinList.h TrajoutList.h Trajout_Single.h VariableArray.h Vec3.h Exec_Calc.o : Exec_Calc.cpp Action.h ActionFrameCounter.h ActionList.h ActionState.h Analysis.h AnalysisList.h AnalysisState.h ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajState.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h EnsembleIn.h EnsembleOut.h EnsembleOutList.h Exec.h Exec_Calc.h FileIO.h FileName.h FileTypes.h Frame.h FrameArray.h FramePtrArray.h InputTrajCommon.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h OutputTrajCommon.h Parallel.h ParameterTypes.h RPNcalc.h Range.h ReferenceFrame.h ReplicaDimArray.h ReplicaInfo.h Residue.h TextFormat.h Timer.h Topology.h TrajFrameCounter.h TrajectoryFile.h TrajectoryIO.h Trajin.h TrajinList.h TrajoutList.h Trajout_Single.h Vec3.h Exec_Change.o : Exec_Change.cpp Action.h ActionFrameCounter.h ActionList.h ActionState.h Analysis.h AnalysisList.h AnalysisState.h ArgList.h AssociatedData.h Atom.h AtomExtra.h AtomMask.h BaseIOtype.h Box.h CharMask.h CoordinateInfo.h CpptrajFile.h CpptrajState.h CpptrajStdio.h DataFile.h DataFileList.h DataIO.h DataSet.h DataSetList.h DataSet_Coords.h DataSet_Coords_REF.h Dimension.h DispatchObject.h EnsembleIn.h EnsembleOut.h EnsembleOutList.h Exec.h Exec_Change.h FileIO.h FileName.h FileTypes.h Frame.h FrameArray.h FramePtrArray.h InputTrajCommon.h MaskToken.h Matrix_3x3.h MetaData.h Molecule.h NameType.h OutputTrajCommon.h Parallel.h ParameterTypes.h Range.h ReferenceFrame.h ReplicaDimArray.h ReplicaInfo.h Residue.h TextFormat.h Timer.h Topology.h TrajFrameCounter.h TrajectoryFile.h TrajectoryIO.h Trajin.h TrajinList.h TrajoutList.h Trajout_Single.h Vec3.h diff --git a/src/cpptrajfiles b/src/cpptrajfiles index 4257e61a6a..fa39074f76 100644 --- a/src/cpptrajfiles +++ b/src/cpptrajfiles @@ -227,6 +227,8 @@ COMMON_SOURCES=ActionFrameCounter.cpp \ EnsembleOut_Single.cpp \ EnsembleOutList.cpp \ Ewald.cpp \ + Ewald_ParticleMesh.cpp \ + Ewald_Regular.cpp \ Exec_Analyze.cpp \ Exec_Calc.cpp \ Exec_Change.cpp \ diff --git a/src/libpme_standalone.h b/src/libpme_standalone.h new file mode 100644 index 0000000000..31b50544af --- /dev/null +++ b/src/libpme_standalone.h @@ -0,0 +1,3164 @@ + +// +// WARNING! This file is automatically generated from the sources in the src directory. +// Do not modify this source code directly as any changes will be overwritten +// + + +// original file: ../src/libpme.h + +// BEGINLICENSE +// +// This file is part of libpme, which is distributed under the BSD 3-clause license, +// as described in the LICENSE file in the top level directory of this project. +// +// Author: Andrew C. Simmonett +// +// ENDLICENSE +#ifndef _LIBPME_LIBPME_H_ +#define _LIBPME_LIBPME_H_ + +#if __cplusplus || DOXYGEN + +// C++ header + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +// original file: ../src/fftw_wrapper.h + +// BEGINLICENSE +// +// This file is part of libpme, which is distributed under the BSD 3-clause license, +// as described in the LICENSE file in the top level directory of this project. +// +// Author: Andrew C. Simmonett +// +// ENDLICENSE +#ifndef _LIBPME_FFTW_WRAPPER_H_ +#define _LIBPME_FFTW_WRAPPER_H_ + +#include +#include +#include +#include + +#include +// original file: ../src/memory.h + +// BEGINLICENSE +// +// This file is part of libpme, which is distributed under the BSD 3-clause license, +// as described in the LICENSE file in the top level directory of this project. +// +// Author: Andrew C. Simmonett +// +// ENDLICENSE +#ifndef _LIBPME_MEMORY_H_ +#define _LIBPME_MEMORY_H_ + +#include +#include + +#include + +namespace libpme { + +/*! + * \brief FFTWAllocator a class to handle aligned allocation of memory using the FFTW libraries. + * Code is adapted from http://www.josuttis.com/cppcode/myalloc.hpp.html. + */ +template +class FFTWAllocator { + public: + // type definitions + typedef T value_type; + typedef T* pointer; + typedef const T* const_pointer; + typedef T& reference; + typedef const T& const_reference; + typedef std::size_t size_type; + typedef std::ptrdiff_t difference_type; + + // rebind allocator to type U + template + struct rebind { + typedef FFTWAllocator other; + }; + + // return address of values + pointer address(reference value) const { return &value; } + const_pointer address(const_reference value) const { return &value; } + + /* constructors and destructor + * - nothing to do because the allocator has no state + */ + FFTWAllocator() throw() {} + FFTWAllocator(const FFTWAllocator&) throw() {} + template + FFTWAllocator(const FFTWAllocator&) throw() {} + ~FFTWAllocator() throw() {} + + // return maximum number of elements that can be allocated + size_type max_size() const throw() { return std::numeric_limits::max() / sizeof(T); } + + // allocate but don't initialize num elements of type T + pointer allocate(size_type num, const void* = 0) { return static_cast(fftw_malloc(num * sizeof(T))); } + + // initialize elements of allocated storage p with value value + void construct(pointer p, const T& value) { + // initialize memory with placement new + new ((void*)p) T(value); + } + + // destroy elements of initialized storage p + void destroy(pointer p) {} + + // deallocate storage p of deleted elements + void deallocate(pointer p, size_type num) { fftw_free(static_cast(p)); } +}; + +// return that all specializations of this allocator are interchangeable +template +bool operator==(const FFTWAllocator&, const FFTWAllocator&) throw() { + return true; +} +template +bool operator!=(const FFTWAllocator&, const FFTWAllocator&) throw() { + return false; +} + +template +using vector = std::vector>; + +} // Namespace libpme + +#endif // Header guard + +namespace libpme { + +/*! + * \brief The FFTWTypes class is a placeholder to lookup function names and types in FFTW parlance by template. + */ +template +struct FFTWTypes; + +template <> +struct FFTWTypes { + using Plan = fftwf_plan; + using Complex = fftwf_complex; + static constexpr decltype(&fftwf_plan_dft_r2c_1d) MakeRealToComplexPlan = &fftwf_plan_dft_r2c_1d; + static constexpr decltype(&fftwf_plan_dft_c2r_1d) MakeComplexToRealPlan = &fftwf_plan_dft_c2r_1d; + static constexpr decltype(&fftwf_plan_dft_1d) MakeComplexToComplexPlan = &fftwf_plan_dft_1d; + static constexpr decltype(&fftwf_execute_dft_r2c) ExecuteRealToComplexPlan = &fftwf_execute_dft_r2c; + static constexpr decltype(&fftwf_execute_dft_c2r) ExecuteComplexToRealPlan = &fftwf_execute_dft_c2r; + static constexpr decltype(&fftwf_execute_dft) ExecuteComplexToComplexPlan = &fftwf_execute_dft; + static constexpr decltype(&fftwf_destroy_plan) DestroyPlan = &fftwf_destroy_plan; + static constexpr decltype(&fftwf_cleanup) CleanupFFTW = &fftwf_cleanup; +}; +template <> +struct FFTWTypes { + using Plan = fftw_plan; + using Complex = fftw_complex; + static constexpr decltype(&fftw_plan_dft_r2c_1d) MakeRealToComplexPlan = &fftw_plan_dft_r2c_1d; + static constexpr decltype(&fftw_plan_dft_c2r_1d) MakeComplexToRealPlan = &fftw_plan_dft_c2r_1d; + static constexpr decltype(&fftw_plan_dft_1d) MakeComplexToComplexPlan = &fftw_plan_dft_1d; + static constexpr decltype(&fftw_execute_dft_r2c) ExecuteRealToComplexPlan = &fftw_execute_dft_r2c; + static constexpr decltype(&fftw_execute_dft_c2r) ExecuteComplexToRealPlan = &fftw_execute_dft_c2r; + static constexpr decltype(&fftw_execute_dft) ExecuteComplexToComplexPlan = &fftw_execute_dft; + static constexpr decltype(&fftw_destroy_plan) DestroyPlan = &fftw_destroy_plan; + static constexpr decltype(&fftw_cleanup) CleanupFFTW = &fftw_cleanup; +}; +template <> +struct FFTWTypes { + using Plan = fftwl_plan; + using Complex = fftwl_complex; + static constexpr decltype(&fftwl_plan_dft_r2c_1d) MakeRealToComplexPlan = &fftwl_plan_dft_r2c_1d; + static constexpr decltype(&fftwl_plan_dft_c2r_1d) MakeComplexToRealPlan = &fftwl_plan_dft_c2r_1d; + static constexpr decltype(&fftwl_plan_dft_1d) MakeComplexToComplexPlan = &fftwl_plan_dft_1d; + static constexpr decltype(&fftwl_execute_dft_r2c) ExecuteRealToComplexPlan = &fftwl_execute_dft_r2c; + static constexpr decltype(&fftwl_execute_dft_c2r) ExecuteComplexToRealPlan = &fftwl_execute_dft_c2r; + static constexpr decltype(&fftwl_execute_dft) ExecuteComplexToComplexPlan = &fftwl_execute_dft; + static constexpr decltype(&fftwl_destroy_plan) DestroyPlan = &fftwl_destroy_plan; + static constexpr decltype(&fftwl_cleanup) CleanupFFTW = &fftwl_cleanup; +}; + +/*! + * \brief The FFTWWrapper class is a convenient wrapper to abstract away the details of different + * precision modes for FFTW, where the types and function names differ. + */ +template +class FFTWWrapper { + using typeinfo = FFTWTypes; + using Plan = typename typeinfo::Plan; + using Complex = typename typeinfo::Complex; + + protected: + /// An FFTW plan object, describing out of place complex to complex forward transforms. + typename typeinfo::Plan forwardPlan_; + /// An FFTW plan object, describing out of place complex to complex inverse transforms. + typename typeinfo::Plan inversePlan_; + /// An FFTW plan object, describing in place complex to complex forward transforms. + typename typeinfo::Plan forwardInPlacePlan_; + /// An FFTW plan object, describing in place complex to complex inverse transforms. + typename typeinfo::Plan inverseInPlacePlan_; + /// An FFTW plan object, describing out of place real to complex forward transforms. + typename typeinfo::Plan realToComplexPlan_; + /// An FFTW plan object, describing out of place complex to real inverse transforms. + typename typeinfo::Plan complexToRealPlan_; + /// The size of the real data. + size_t fftDimension_; + /// The flags to be passed to the FFTW plan creator, to determine startup cost. + unsigned transformFlags_; + + public: + FFTWWrapper() {} + FFTWWrapper(size_t fftDimension) : fftDimension_(fftDimension), transformFlags_(FFTW_ESTIMATE) { + libpme::vector realTemp(fftDimension_); + libpme::vector> complexTemp1(fftDimension_); + libpme::vector> complexTemp2(fftDimension_); + Real *realPtr = realTemp.data(); + Complex *complexPtr1 = reinterpret_cast(complexTemp1.data()); + Complex *complexPtr2 = reinterpret_cast(complexTemp2.data()); + forwardPlan_ = + typeinfo::MakeComplexToComplexPlan(fftDimension_, complexPtr1, complexPtr2, FFTW_FORWARD, transformFlags_); + inversePlan_ = + typeinfo::MakeComplexToComplexPlan(fftDimension_, complexPtr1, complexPtr2, FFTW_BACKWARD, transformFlags_); + forwardInPlacePlan_ = + typeinfo::MakeComplexToComplexPlan(fftDimension_, complexPtr1, complexPtr1, FFTW_FORWARD, transformFlags_); + inverseInPlacePlan_ = + typeinfo::MakeComplexToComplexPlan(fftDimension_, complexPtr1, complexPtr1, FFTW_BACKWARD, transformFlags_); + realToComplexPlan_ = typeinfo::MakeRealToComplexPlan(fftDimension_, realPtr, complexPtr1, transformFlags_); + complexToRealPlan_ = typeinfo::MakeComplexToRealPlan(fftDimension_, complexPtr1, realPtr, transformFlags_); + } + + /*! + * \brief transform call FFTW to do an out of place complex to real FFT. + * \param inBuffer the location of the input data. + * \param outBuffer the location of the output data. + */ + void transform(std::complex *inBuffer, Real *outBuffer) { + typeinfo::ExecuteComplexToRealPlan(complexToRealPlan_, reinterpret_cast(inBuffer), outBuffer); + } + + /*! + * \brief transform call FFTW to do an out of place real to complex FFT. + * \param inBuffer the location of the input data. + * \param outBuffer the location of the output data. + */ + void transform(Real *inBuffer, std::complex *outBuffer) { + typeinfo::ExecuteRealToComplexPlan(realToComplexPlan_, inBuffer, reinterpret_cast(outBuffer)); + } + + /*! + * \brief transform call FFTW to do an in place complex to complex FFT. + * \param inPlaceBuffer the location of the input and output data. + * \param direction either FFTW_FORWARD or FFTW_BACKWARD. + */ + void transform(std::complex *inPlaceBuffer, int direction) { + Complex *inPlacePtr = reinterpret_cast(inPlaceBuffer); + switch (direction) { + case FFTW_FORWARD: + typeinfo::ExecuteComplexToComplexPlan(forwardInPlacePlan_, inPlacePtr, inPlacePtr); + break; + case FFTW_BACKWARD: + typeinfo::ExecuteComplexToComplexPlan(inverseInPlacePlan_, inPlacePtr, inPlacePtr); + break; + default: + throw std::runtime_error("Invalid FFTW transform passed to in place transform()."); + } + } + + /*! + * \brief transform call FFTW to do an out of place complex to complex FFT. + * \param inBuffer the location of the input data. + * \param outBuffer the location of the output data. + * \param direction either FFTW_FORWARD or FFTW_BACKWARD. + */ + void transform(std::complex *inBuffer, std::complex *outBuffer, int direction) { + Complex *inPtr = reinterpret_cast(inBuffer); + Complex *outPtr = reinterpret_cast(outBuffer); + switch (direction) { + case FFTW_FORWARD: + typeinfo::ExecuteComplexToComplexPlan(forwardPlan_, inPtr, outPtr); + break; + case FFTW_BACKWARD: + typeinfo::ExecuteComplexToComplexPlan(inversePlan_, inPtr, outPtr); + break; + default: + throw std::runtime_error("Invalid FFTW transform passed to transform()."); + } + } +}; + +} // Namespace libpme +#endif // Header guard +// original file: ../src/gamma.h + +// BEGINLICENSE +// +// This file is part of libpme, which is distributed under the BSD 3-clause license, +// as described in the LICENSE file in the top level directory of this project. +// +// Author: Andrew C. Simmonett +// +// ENDLICENSE +#ifndef _LIBPME_GAMMA_H_ +#define _LIBPME_GAMMA_H_ + +#include +#include +#include + +/*! + * \file gamma.h + * \brief Contains C++ implementations of templated gamma and incomplete gamma functions, computed using recursion. + */ + +namespace libpme { + +constexpr long double sqrtPi = 1.77245385090551602729816748334114518279754945612238712821381L; + +/*! + * Compute upper incomplete gamma functions for positive half-integral s values using the recursion + * \f$ \Gamma[\frac{\mathrm{twoS}}{2},x] = \Gamma[\frac{\mathrm{twoS}-2}{2},x] + x^{\frac{\mathrm{twoS}-2}{2}}e^{-x}\f$ + */ +template +struct incompleteGammaRecursion { + static Real compute(Real x) { + return (0.5f * twoS - 1) * incompleteGammaRecursion::compute(x) + + pow(x, (0.5f * twoS - 1)) * exp(-x); + } +}; + +/*! + * Compute upper incomplete gamma functions for negative half-integral s values using the recursion + * \f$ \Gamma[\frac{\mathrm{twoS}}{2},x] = \frac{2\Gamma[\frac{\mathrm{twoS}+2}{2},x] - + * 2x^\frac{\mathrm{twoS}}{2}e^{-x}}{\mathrm{twoS}}\f$ + */ +template +struct incompleteGammaRecursion { + static Real compute(Real x) { + return (incompleteGammaRecursion::compute(x) - pow(x, 0.5f * twoS) * exp(-x)) / + (0.5f * twoS); + } +}; + +/// Specific value of incomplete gamma function. +template +struct incompleteGammaRecursion { + static Real compute(Real x) { return exp(-x); } +}; + +/// Specific value of incomplete gamma function. +template +struct incompleteGammaRecursion { + static Real compute(Real x) { return sqrtPi * erfc(std::sqrt(x)); } +}; + +/// Specific value of incomplete gamma function. +template +struct incompleteGammaRecursion { + static Real compute(Real x) { return sqrtPi * erfc(std::sqrt(x)); } +}; + +/// Specific value of incomplete gamma function. +template +struct incompleteGammaRecursion { + static Real compute(Real x) { + // Gamma(0,x) is (minus) the exponential integral of -x. This implementation was stolen from + // http://www.mymathlib.com/c_source/functions/exponential_integrals/exponential_integral_Ei.c + x = -x; + if (x < -5.0L) return -(Real)Continued_Fraction_Ei(x); + if (x == 0.0L) return std::numeric_limits::max(); + if (x < 6.8L) return -(Real)Power_Series_Ei(x); + if (x < 50.0L) return -(Real)Argument_Addition_Series_Ei(x); + return -(Real)Continued_Fraction_Ei(x); + } + + private: + static constexpr long double epsilon = 10.0 * std::numeric_limits::epsilon(); + + //////////////////////////////////////////////////////////////////////////////// + // static long double Continued_Fraction_Ei( long double x ) // + // // + // Description: // + // For x < -5 or x > 50, the continued fraction representation of Ei // + // converges fairly rapidly. // + // // + // The continued fraction expansion of Ei(x) is: // + // Ei(x) = -exp(x) { 1/(-x+1-) 1/(-x+3-) 4/(-x+5-) 9/(-x+7-) ... }. // + // // + // // + // Arguments: // + // long double x // + // The argument of the exponential integral Ei(). // + // // + // Return Value: // + // The value of the exponential integral Ei evaluated at x. // + //////////////////////////////////////////////////////////////////////////////// + + static long double Continued_Fraction_Ei(long double x) { + long double Am1 = 1.0L; + long double A0 = 0.0L; + long double Bm1 = 0.0L; + long double B0 = 1.0L; + long double a = std::exp(x); + long double b = -x + 1.0L; + long double Ap1 = b * A0 + a * Am1; + long double Bp1 = b * B0 + a * Bm1; + int j = 1; + + a = 1.0L; + while (std::fabs(Ap1 * B0 - A0 * Bp1) > epsilon * std::fabs(A0 * Bp1)) { + if (std::fabs(Bp1) > 1.0L) { + Am1 = A0 / Bp1; + A0 = Ap1 / Bp1; + Bm1 = B0 / Bp1; + B0 = 1.0L; + } else { + Am1 = A0; + A0 = Ap1; + Bm1 = B0; + B0 = Bp1; + } + a = -j * j; + b += 2.0L; + Ap1 = b * A0 + a * Am1; + Bp1 = b * B0 + a * Bm1; + j += 1; + } + return (-Ap1 / Bp1); + } + + //////////////////////////////////////////////////////////////////////////////// + // static long double Power_Series_Ei( long double x ) // + // // + // Description: // + // For -5 < x < 6.8, the power series representation for (Ei(x) - gamma // + // - ln|x|)/exp(x) is used, where gamma is Euler's gamma constant. // + // Note that for x = 0.0, Ei is -inf. In which case -DBL_MAX is // + // returned. // + // // + // The power series expansion of (Ei(x) - gamma - ln|x|) / exp(x) is // + // - Sum(1 + 1/2 + ... + 1/j) (-x)^j / j!, where the Sum extends // + // from j = 1 to inf. // + // // + // Arguments: // + // long double x // + // The argument of the exponential integral Ei(). // + // // + // Return Value: // + // The value of the exponential integral Ei evaluated at x. // + //////////////////////////////////////////////////////////////////////////////// + + static long double Power_Series_Ei(long double x) { + long double xn = -x; + long double Sn = -x; + long double Sm1 = 0.0L; + long double hsum = 1.0L; + long double g = 0.5772156649015328606065121L; + long double y = 1.0L; + long double factorial = 1.0L; + + while (std::fabs(Sn - Sm1) > epsilon * std::fabs(Sm1)) { + Sm1 = Sn; + y += 1.0L; + xn *= (-x); + factorial *= y; + hsum += (1.0 / y); + Sn += hsum * xn / factorial; + } + return (g + std::log(std::fabs(x)) - std::exp(x) * Sn); + } + + //////////////////////////////////////////////////////////////////////////////// + // static long double Argument_Addition_Series_Ei(long double x) // + // // + // Description: // + // For 6.8 < x < 50.0, the argument addition series is used to calculate // + // Ei. // + // // + // The argument addition series for Ei(x) is: // + // Ei(x+dx) = Ei(x) + exp(x) Sum j! [exp(j) expj(-dx) - 1] / x^(j+1), // + // where the Sum extends from j = 0 to inf, |x| > |dx| and expj(y) is // + // the exponential polynomial expj(y) = Sum y^k / k!, // + // the Sum extending from k = 0 to k = j. // + // // + // Arguments: // + // long double x // + // The argument of the exponential integral Ei(). // + // // + // Return Value: // + // The value of the exponential integral Ei evaluated at x. // + //////////////////////////////////////////////////////////////////////////////// + static long double Argument_Addition_Series_Ei(long double x) { + static long double ei[] = { + 1.915047433355013959531e2L, 4.403798995348382689974e2L, 1.037878290717089587658e3L, + 2.492228976241877759138e3L, 6.071406374098611507965e3L, 1.495953266639752885229e4L, + 3.719768849068903560439e4L, 9.319251363396537129882e4L, 2.349558524907683035782e5L, + 5.955609986708370018502e5L, 1.516637894042516884433e6L, 3.877904330597443502996e6L, + 9.950907251046844760026e6L, 2.561565266405658882048e7L, 6.612718635548492136250e7L, + 1.711446713003636684975e8L, 4.439663698302712208698e8L, 1.154115391849182948287e9L, + 3.005950906525548689841e9L, 7.842940991898186370453e9L, 2.049649711988081236484e10L, + 5.364511859231469415605e10L, 1.405991957584069047340e11L, 3.689732094072741970640e11L, + 9.694555759683939661662e11L, 2.550043566357786926147e12L, 6.714640184076497558707e12L, + 1.769803724411626854310e13L, 4.669055014466159544500e13L, 1.232852079912097685431e14L, + 3.257988998672263996790e14L, 8.616388199965786544948e14L, 2.280446200301902595341e15L, + 6.039718263611241578359e15L, 1.600664914324504111070e16L, 4.244796092136850759368e16L, + 1.126348290166966760275e17L, 2.990444718632336675058e17L, 7.943916035704453771510e17L, + 2.111342388647824195000e18L, 5.614329680810343111535e18L, 1.493630213112993142255e19L, + 3.975442747903744836007e19L, 1.058563689713169096306e20L}; + int k = (int)(x + 0.5f); + int j = 0; + long double xx = (long double)k; + long double dx = x - xx; + long double xxj = xx; + long double edx = std::exp(dx); + long double Sm = 1.0L; + long double Sn = (edx - 1.0L) / xxj; + long double term = std::numeric_limits::max(); + long double factorial = 1.0L; + long double dxj = 1.0L; + + while (std::fabs(term) > epsilon * std::fabs(Sn)) { + j++; + factorial *= (long double)j; + xxj *= xx; + dxj *= (-dx); + Sm += (dxj / factorial); + term = (factorial * (edx * Sm - 1.0L)) / xxj; + Sn += term; + } + + return ei[k - 7] + Sn * std::exp(xx); + } +}; + +/*! + * Compute gamma function for positive half-integral s values using the recursion. + * \f$ \Gamma[\frac{\mathrm{twoS}}{2}] = \Gamma[\frac{\mathrm{twoS}-2}{2}]\frac{\mathrm{twoS}-2}{2} \f$ + */ +template +struct gammaRecursion { + static constexpr Real value = gammaRecursion::value * (0.5f * twoS - 1); +}; + +/*! + * Compute gamma function for negative half-integral s values using the recursion. + * \f$ \Gamma[\frac{\mathrm{twoS}}{2}] = \frac{2\Gamma[\frac{\mathrm{twoS}_2}{2}]}{\mathrm{twoS}} \f$ + * Returns infinity (expressed as the largest value representable by Real) for \f$twoS = 0, -2, -4, -6, \ldots\f$ . + */ +template +struct gammaRecursion { + static constexpr Real value = gammaRecursion::value == std::numeric_limits::max() + ? std::numeric_limits::max() + : gammaRecursion::value / (0.5f * twoS); +}; + +/// Specific value of the Gamma function. +template +struct gammaRecursion { + static constexpr Real value = std::numeric_limits::max(); +}; + +/// Specific value of the Gamma function. +template +struct gammaRecursion { + static constexpr Real value = sqrtPi; +}; + +/// Specific value of the Gamma function. +template +struct gammaRecursion { + static constexpr Real value = sqrtPi; +}; + +/// Specific value of the Gamma function. +template +struct gammaRecursion { + static constexpr Real value = 1.0; +}; + +/// Specific value of the Gamma function. +template +struct gammaRecursion { + static constexpr Real value = 1.0; +}; + +/*! + * \class incompleteGammaComputer + * \brief Computes the upper incomplete Gamma function. + * \f$ \Gamma[s,x] = \int_x^\infty t^{s-1} e^{-t} \mathrm{d}t \f$ + * In this code we only need half integral arguments for \f$s\f$, and only positive \f$x\f$ arguments. + * \tparam Real the floating point type to use for arithmetic. + * \tparam twoS twice the s value required. + */ +template +struct incompleteGammaComputer { + /*! + * \brief Computes the incomplete gamma function. + * \param x value required. + * \return \f$\Gamma[\frac{\mathrm{twoS}}{2}, x^2]\f$. + */ + static Real compute(Real x) { return incompleteGammaRecursion 0)>::compute(x); } +}; + +/*! + * Compute upper incomplete gamma functions for positive half-integral s values using the recursion + * \f$ \Gamma[\frac{\mathrm{twoS}}{2},x] = \Gamma[\frac{\mathrm{twoS}-2}{2},x] + x^{\frac{\mathrm{twoS}-2}{2}}e^{-x}\f$ + */ +template +struct incompleteVirialGammaRecursion { + static std::tuple compute(Real x) { + Real gamma = incompleteGammaComputer::compute(x); + return std::make_tuple(gamma, (0.5f * twoS) * gamma + pow(x, (0.5f * twoS)) * exp(-x)); + } +}; + +/*! + * Compute upper incomplete gamma functions for negative half-integral s values using the recursion + * \f$ \Gamma[\frac{\mathrm{twoS}}{2},x] = \frac{2\Gamma[\frac{\mathrm{twoS}+2}{2},x] - + * 2x^\frac{\mathrm{twoS}}{2}e^{-x}}{\mathrm{twoS}}\f$ + */ +template +struct incompleteVirialGammaRecursion { + static std::tuple compute(Real x) { + Real gamma = incompleteGammaComputer::compute(x); + return std::make_tuple((gamma - pow(x, 0.5f * twoS) * exp(-x)) / (0.5f * twoS), gamma); + } +}; + +/*! + * \class incompleteGammaVirialComputer + * \brief Computes the upper incomplete Gamma function for two different values: s and s+1. + * \f$ \Gamma[s,x] = \int_x^\infty t^{s-1} e^{-t} \mathrm{d}t \f$ + * In this code we only need half integral arguments for \f$s\f$, and only positive \f$x\f$ arguments. + * \tparam Real the floating point type to use for arithmetic. + * \tparam twoS twice the s value required. + */ +template +struct incompleteGammaVirialComputer { + /*! + * \brief Computes the incomplete gamma function for argument twoS and twoS+2. + * \param x value required. + * \return \f$\Gamma[\frac{\mathrm{twoS}}{2}, x]\f$ and \f$\Gamma[\frac{\mathrm{twoS+2}}{2}, x]\f$. + */ + static std::tuple compute(Real x) { + return incompleteVirialGammaRecursion= 0)>::compute(x); + } +}; + +/*! + * \class gammaComputer + * \brief Computes the Gamma function. + * \f$ \Gamma[s] = \int_0^\infty t^{s-1} e^{-t} \mathrm{d}t \f$ + * In this code we only need half integral values for the \f$s\f$ argument, so the input + * argument \f$s\f$ will yield \f$\Gamma[\frac{s}{2}]\f$. + * \tparam Real the floating point type to use for arithmetic. + * \tparam twoS twice the s value required. + */ +template +struct gammaComputer { + /// The value of \f$\Gamma[\frac{\mathrm{twos}}{2}]\f$ + static constexpr Real value = gammaRecursion 0)>::value; +}; + +} // Namespace libpme +#endif // Header guard +// original file: ../src/matrix.h + +// BEGINLICENSE +// +// This file is part of libpme, which is distributed under the BSD 3-clause license, +// as described in the LICENSE file in the top level directory of this project. +// +// Author: Andrew C. Simmonett +// +// ENDLICENSE +#ifndef _LIBPME_MATRIX_H_ +#define _LIBPME_MATRIX_H_ + +#include +#include +#include +#include +#include +#include +#include +#include + +// original file: ../src/lapack_wrapper.h + +// BEGINLICENSE +// +// This file is part of libpme, which is distributed under the BSD 3-clause license, +// as described in the LICENSE file in the top level directory of this project. +// +// Author: Andrew C. Simmonett +// +// ENDLICENSE +#ifndef _LIBPME_LAPACK_WRAPPER_H_ +#define _LIBPME_LAPACK_WRAPPER_H_ + +#include +#include + +#if FC_SYMBOL == 2 +#define F_SGEEV sgeev_ +#define F_SGESV sgesv_ +#define F_DGEEV dgeev_ +#define F_DGESV dgesv_ +#define F_CGEEV cgeev_ +#define F_CGESV cgesv_ +#define F_ZGEEV zgeev_ +#define F_ZGESV zgesv_ +#elif FC_SYMBOL == 1 +#define F_SGEEV sgeev +#define F_SGESV sgesv +#define F_DGEEV dgeev +#define F_DGESV dgesv +#define F_CGEEV cgeev +#define F_CGESV cgesv +#define F_ZGEEV zgeev +#define F_ZGESV zgesv +#elif FC_SYMBOL == 3 +#define F_SGEEV SGEEV +#define F_SGESV SGESV +#define F_DGEEV DGEEV +#define F_DGESV DGESV +#define F_CGEEV CGEEV +#define F_CGESV CGESV +#define F_ZGEEV ZGEEV +#define F_ZGESV ZGESV +#elif FC_SYMBOL == 4 +#define F_SGEEV SGEEV_ +#define F_SGESV SGESV_ +#define F_DGEEV DGEEV_ +#define F_DGESV DGESV_ +#define F_CGEEV CGEEV_ +#define F_CGESV CGESV_ +#define F_ZGEEV ZGEEV_ +#define F_ZGESV ZGESV_ +#endif + +extern "C" { +/*extern void F_SGEEV(char *, char *, int *, float *, int *, float *, float *, float *, int *, float *, int *, float *, + int *, int *);*/ +extern void F_DGEEV(char *, char *, int *, double *, int *, double *, double *, double *, int *, double *, int *, + double *, int *, int *); +/*extern void F_CGEEV(char *, char *, int *, std::complex *, int *, std::complex *, std::complex *, + std::complex *, int *, std::complex *, int *, std::complex *, int *, int *); +extern void F_ZGEEV(char *, char *, int *, std::complex *, int *, std::complex *, + std::complex *, std::complex *, int *, std::complex *, int *, + std::complex *, int *, int *);*/ +} + +namespace libpme { +/* +static void C_SGEEV(char jobvl, char jobvr, int n, float *a, int lda, float *wr, float *wi, float *vl, int ldvl, + float *vr, int ldvr, float *work, int lwork, int *info) { + ::F_SGEEV(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, info); +} +*/ +static void C_DGEEV(char jobvl, char jobvr, int n, double *a, int lda, double *wr, double *wi, double *vl, int ldvl, + double *vr, int ldvr, double *work, int lwork, int *info) { + ::F_DGEEV(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, info); +} +/* +static void C_CGEEV(char jobvl, char jobvr, int n, std::complex *a, int lda, std::complex *wr, + std::complex *wi, std::complex *vl, int ldvl, std::complex *vr, int ldvr, + std::complex *work, int lwork, int *info) { + ::F_CGEEV(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, info); +} + +static void C_ZGEEV(char jobvl, char jobvr, int n, std::complex *a, int lda, std::complex *wr, + std::complex *wi, std::complex *vl, int ldvl, std::complex *vr, int ldvr, + std::complex *work, int lwork, int *info) { + ::F_ZGEEV(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, info); +} +*/ +template +using diagonalizerType = + std::function; + +template +class LapackWrapper { + public: + static diagonalizerType diagonalizer() { + throw std::runtime_error("Diagonalization is not implemented for the requested data type"); + return diagonalizerType(); + } +}; +/* +template <> +inline diagonalizerType LapackWrapper::diagonalizer() { + return &C_SGEEV; +}*/ +template <> +inline diagonalizerType LapackWrapper::diagonalizer() { + return &C_DGEEV; +} +/*template <> +inline diagonalizerType> LapackWrapper>::diagonalizer() { + return &C_CGEEV; +} +template <> +inline diagonalizerType> LapackWrapper>::diagonalizer() { + return &C_ZGEEV; +}*/ + +} // Namespace libpme +#endif // Header guard +// #include "memory.h" + +namespace libpme { + +/*! + * A helper function to transpose a dense matrix in place, gratuitously stolen from + * https://stackoverflow.com/questions/9227747/in-place-transposition-of-a-matrix + */ +template +void transposeMemoryInPlace(RandomIterator first, RandomIterator last, int m) { + const int mn1 = (last - first - 1); + const int n = (last - first) / m; + std::vector visited(last - first); + RandomIterator cycle = first; + while (++cycle != last) { + if (visited[cycle - first]) continue; + int a = cycle - first; + do { + a = a == mn1 ? mn1 : (n * a) % mn1; + std::swap(*(first + a), *cycle); + visited[a] = true; + } while ((first + a) != cycle); + } +} + +/*! + * \brief The Matrix class is designed to serve as a convenient wrapper to simplify 2D matrix operations. + * It assumes dense matrices with contiguious data and the fast running index being the right + * (column) index. The underlying memory may have already been allocated elsewhere by C, Fortran + * or Python, and is directly manipulated in place, saving an expensive copy operation. To provide + * read-only access to such memory address, use a const template type. + */ +template +class Matrix { + protected: + /// The number of rows in the matrix. + size_t nRows_; + /// The number of columns in the matrix. + size_t nCols_; + /// A vector to conveniently allocate data, if we really need to. + libpme::vector allocatedData_; + /// Pointer to the raw data, whose allocation may not be controlled by us. + Real* data_; + + public: + enum class SortOrder { Ascending, Descending }; + + const Real& operator()(int row, int col) const { return *(data_ + row * nCols_ + col); } + Real& operator()(int row, int col) { return *(data_ + row * nCols_ + col); } + const Real* operator[](int row) const { return data_ + row * nCols_; } + Real* operator[](int row) { return data_ + row * nCols_; } + + Real* begin() { return data_; } + Real* end() { return data_ + nRows_ * nCols_; } + const Real* cbegin() const { return data_; } + const Real* cend() const { return data_ + nRows_ * nCols_; } + + /*! + * \brief The sliceIterator struct provides a read-only view of a sub-block of a matrix, with arbitrary size. + */ + struct sliceIterator { + Real *begin_, *end_, *ptr_; + size_t stride_; + sliceIterator(Real* start, Real* end, size_t stride) : begin_(start), end_(end), ptr_(start), stride_(stride) {} + sliceIterator begin() const { return sliceIterator(begin_, end_, stride_); } + sliceIterator end() const { return sliceIterator(end_, end_, 0); } + sliceIterator cbegin() const { return sliceIterator(begin_, end_, stride_); } + sliceIterator cend() const { return sliceIterator(end_, end_, 0); } + bool operator!=(const sliceIterator& other) { return ptr_ != other.ptr_; } + sliceIterator operator*=(Real val) { + for (auto& element : *this) element *= val; + return *this; + } + sliceIterator operator/=(Real val) { + Real invVal = 1 / val; + for (auto& element : *this) element *= invVal; + return *this; + } + sliceIterator operator-=(Real val) { + for (auto& element : *this) element -= val; + return *this; + } + sliceIterator operator+=(Real val) { + for (auto& element : *this) element += val; + return *this; + } + sliceIterator operator++() { + ptr_ += stride_; + return *this; + } + const Real& operator[](size_t index) { return *(begin_ + index); } + size_t size() const { return std::distance(begin_, end_) / stride_; } + void assertSameSize(const sliceIterator& other) const { + if (size() != other.size()) + throw std::runtime_error("Slice operations only supported for slices of the same size."); + } + void assertContiguous(const sliceIterator& iter) const { + if (iter.stride_ != 1) + throw std::runtime_error( + "Slice operations called on operation that is only allowed for contiguous data."); + } + Matrix operator-(const sliceIterator& other) const { + assertSameSize(other); + assertContiguous(*this); + assertContiguous(other); + Matrix ret(1, size()); + std::transform(begin_, end_, other.begin_, ret[0], + [](const Real& a, const Real& b) -> Real { return a - b; }); + return ret; + } + sliceIterator operator-=(const sliceIterator& other) const { + assertSameSize(other); + assertContiguous(*this); + assertContiguous(other); + std::transform(begin_, end_, other.begin_, begin_, + [](const Real& a, const Real& b) -> Real { return a - b; }); + return *this; + } + sliceIterator operator+=(const sliceIterator& other) const { + assertSameSize(other); + assertContiguous(*this); + assertContiguous(other); + std::transform(begin_, end_, other.begin_, begin_, + [](const Real& a, const Real& b) -> Real { return a + b; }); + return *this; + } + Real& operator*() { return *ptr_; } + }; + + /*! + * \brief row returns a read-only iterator over a given row. + * \param r the row to return. + * \return the slice in memory corresponding to the rth row. + */ + sliceIterator row(size_t r) const { return sliceIterator(data_ + r * nCols_, data_ + (r + 1) * nCols_, 1); } + + /*! + * \brief col returns a read-only iterator over a given column. + * \param c the column to return. + * \return the slice in memory corresponding to the cth column. + */ + sliceIterator col(size_t c) const { return sliceIterator(data_ + c, data_ + nRows_ * nCols_ + c, nCols_); } + + /*! + * \return the number of rows in this matrix. + */ + size_t nRows() const { return nRows_; } + + /*! + * \return the number of columns in this matrix. + */ + size_t nCols() const { return nCols_; } + + /*! + * \brief Matrix Constructs an empty matrix. + */ + Matrix() {} + + /*! + * \brief Matrix Constructs a new matrix, allocating memory. + * \param nRows the number of rows in the matrix. + * \param nCols the number of columns in the matrix. + */ + Matrix(size_t nRows, size_t nCols) + : nRows_(nRows), nCols_(nCols), allocatedData_(nRows * nCols, 0), data_(allocatedData_.data()) {} + + /*! + * \brief Matrix Constructs a new matrix, allocating memory and initializing values using the braced initializer. + * \param data a braced initializer list of braced initializer lists containing the values to be stored in the + * matrix. + */ + Matrix(std::initializer_list> data) { + nRows_ = data.size(); + nCols_ = nRows_ ? data.begin()->size() : 0; + allocatedData_.reserve(nRows_ * nCols_); + for (auto& row : data) { + if (row.size() != nCols_) throw std::runtime_error("Inconsistent row dimensions in matrix specification."); + allocatedData_.insert(allocatedData_.end(), row.begin(), row.end()); + } + data_ = allocatedData_.data(); + } + + /*! + * \brief Matrix Constructs a new column vector, allocating memory and initializing values using the braced + * initializer. \param data a braced initializer list of braced initializer lists containing the values to be stored + * in the matrix. + */ + Matrix(std::initializer_list data) : allocatedData_(data), data_(allocatedData_.data()) { + nRows_ = data.size(); + nCols_ = 1; + } + + /*! + * \brief Matrix Constructs a new matrix using already allocated memory. + * \param ptr the already-allocated memory underlying this matrix. + * \param nRows the number of rows in the matrix. + * \param nCols the number of columns in the matrix. + */ + Matrix(Real* ptr, size_t nRows, size_t nCols) : nRows_(nRows), nCols_(nCols), data_(ptr) {} + + /*! + * \brief cast make a copy of this matrix, with its elements cast as a different type. + * \tparam NewReal the type to cast each element to. + * \return the copy of the matrix with the new type. + */ + template + Matrix cast() const { + Matrix newMat(nRows_, nCols_); + NewReal* newPtr = newMat[0]; + const Real* dataPtr = data_; + for (size_t addr = 0; addr < nRows_ * nCols_; ++addr) *newPtr++ = static_cast(*dataPtr++); + return newMat; + } + + /*! + * \brief setConstant sets all elements of this matrix to a specified value. + * \param value the value to set each element to. + */ + void setConstant(Real value) { std::fill(begin(), end(), value); } + + /*! + * \brief setZero sets each element of this matrix to zero. + */ + void setZero() { setConstant(0); } + + /*! + * \brief isNearZero checks that each element in this matrix has an absolute value below some threshold. + * \param threshold the value below which an element is considered zero. + * \return whether all values are near zero or not. + */ + bool isNearZero(Real threshold = 1e-10f) const { + return !std::any_of(cbegin(), cend(), [&](const Real& val) { return std::abs(val) > threshold; }); + } + + /*! + * \brief inverse inverts this matrix, leaving the original matrix untouched. + * \return the inverse of this matrix. + */ + Matrix inverse() const { + assertSquare(); + + Matrix matrixInverse(nRows_, nRows_); + + if (nRows() == 3) { + // 3x3 is a really common case, so treat it here as. + Real determinant = data_[0] * (data_[4] * data_[8] - data_[7] * data_[5]) - + data_[1] * (data_[3] * data_[8] - data_[5] * data_[6]) + + data_[2] * (data_[3] * data_[7] - data_[4] * data_[6]); + + Real determinantInverse = 1 / determinant; + + matrixInverse.data_[0] = (data_[4] * data_[8] - data_[7] * data_[5]) * determinantInverse; + matrixInverse.data_[1] = (data_[2] * data_[7] - data_[1] * data_[8]) * determinantInverse; + matrixInverse.data_[2] = (data_[1] * data_[5] - data_[2] * data_[4]) * determinantInverse; + matrixInverse.data_[3] = (data_[5] * data_[6] - data_[3] * data_[8]) * determinantInverse; + matrixInverse.data_[4] = (data_[0] * data_[8] - data_[2] * data_[6]) * determinantInverse; + matrixInverse.data_[5] = (data_[3] * data_[2] - data_[0] * data_[5]) * determinantInverse; + matrixInverse.data_[6] = (data_[3] * data_[7] - data_[6] * data_[4]) * determinantInverse; + matrixInverse.data_[7] = (data_[6] * data_[1] - data_[0] * data_[7]) * determinantInverse; + matrixInverse.data_[8] = (data_[0] * data_[4] - data_[3] * data_[1]) * determinantInverse; + } else { + // Generic case; just use spectral decomposition, invert the eigenvalues, and stitch back together. + // Note that this only works for symmetric matrices. Need to hook into Lapack for a general + // inversion routine if this becomes a limitation. + return this->applyOperation([](Real& element) { element = 1 / element; }); + } + return matrixInverse; + } + + /*! + * \brief assertSymmetric checks that this matrix is symmetric within some threshold. + * \param threshold the value below which an pair's difference is considered zero. + */ + void assertSymmetric(const Real& threshold = 1e-10f) const { + assertSquare(); + for (int row = 0; row < nRows_; ++row) { + for (int col = 0; col < row; ++col) { + if (std::abs(data_[row * nCols_ + col] - data_[col * nCols_ + row]) > threshold) + throw std::runtime_error("Unexpected non-symmetric matrix found."); + } + } + } + + /*! + * \brief applyOperationToEachElement modifies every element in the matrix by applying an operation. + * \param function a unary operator describing the operation to perform. + */ + void applyOperationToEachElement(const std::function& function) { + std::for_each(begin(), end(), function); + } + + /*! + * \brief applyOperation applies an operation to this matrix using the spectral decomposition, + * leaving the original untouched. Only for symmetric matrices, as coded. + * \param function a undary operator describing the operation to perform. + * \return the matrix transformed by the operator. + */ + Matrix applyOperation(const std::function& function) const { + assertSymmetric(); + + auto eigenPairs = this->diagonalize(); + Matrix evalsReal = std::get<0>(eigenPairs); + Matrix evalsImag = std::get<1>(eigenPairs); + Matrix evecs = std::get<2>(eigenPairs); + if (!evalsImag.isNearZero()) + throw std::runtime_error("Unexpected complex eigenvalues encountered when applying operator to Matrix."); + evalsReal.applyOperationToEachElement(function); + Matrix evecsT = evecs.transpose(); + for (int row = 0; row < nRows_; ++row) { + Real transformedEigenvalue = evalsReal[row][0]; + std::for_each(evecsT.data_ + row * nCols_, evecsT.data_ + (row + 1) * nCols_, + [&](Real& val) { val *= transformedEigenvalue; }); + } + return evecs * evecsT; + } + + /*! + * \brief assertSameSize make sure that this Matrix has the same dimensions as another Matrix. + * \param other the matrix to compare to. + */ + void assertSameSize(const Matrix& other) const { + if (nRows_ != other.nRows_ || nCols_ != other.nCols_) + throw std::runtime_error("Attepting to compare matrices of different sizes!"); + } + + /*! + * \brief assertSquare make sure that this Matrix is square. + */ + void assertSquare() const { + if (nRows_ != nCols_) + throw std::runtime_error("Attepting to perform a square matrix operation on a non-square matrix!"); + } + + /*! + * \brief multiply this matrix with another, returning a new matrix containing the product. + * \param other the right hand side of the matrix product. + * \return the product of this matrix with the matrix other. + */ + Matrix multiply(const Matrix& other) const { + // TODO one fine day this should be replaced by GEMM calls, if matrix multiplies actually get used much. + if (nCols_ != other.nRows_) + throw std::runtime_error("Attempting to multiply matrices with incompatible dimensions."); + Matrix product(nRows_, other.nCols_); + Real* output = product.data_; + for (int row = 0; row < nRows_; ++row) { + const Real* rowPtr = data_ + row * nCols_; + for (int col = 0; col < other.nCols_; ++col) { + for (int link = 0; link < nCols_; ++link) { + *output += rowPtr[link] * other.data_[link * other.nCols_ + col]; + } + ++output; + } + } + return product; + } + + /*! + * \brief operator * a convenient wrapper for the multiply function. + * \param other the right hand side of the matrix product. + * \return the product of this matrix with the matrix other. + */ + Matrix operator*(const Matrix& other) const { return this->multiply(other); } + + /*! + * \brief almostEquals checks that two matrices have all elements the same, within some specificied tolerance. + * \param other the matrix against which we're comparing. + * \param tol the amount that each element is allowed to deviate by. + * \return whether the two matrices are almost equal. + */ + template ::value, int>::type = 0> + bool almostEquals(const Matrix& other, Real tolerance = 1e-6) const { + // The floating point version + assertSameSize(other); + + return std::equal(cbegin(), cend(), other.cbegin(), [&tolerance](Real a, Real b) -> bool { + return (((a - b) < std::real(tolerance)) && ((a - b) > -std::real(tolerance))); + }); + } + template ::value, int>::type = 0> + bool almostEquals(const Matrix& other, Real tolerance = 1e-6) const { + // The complex version + assertSameSize(other); + + auto tol = std::real(tolerance); + // This is a little confusing, but the type "Real" is actually some king of std::complex<...>. + return std::equal(cbegin(), cend(), other.cbegin(), [&tol](Real a, Real b) -> bool { + return (((a.real() - b.real()) < tol) && ((a.real() - b.real()) > -tol) && ((a.imag() - b.imag()) < tol) && + ((a.imag() - b.imag()) > -tol)); + }); + } + + /*! + * \brief dot computes the inner product of this matrix with another. + * \param other the other matrix in the inner product, which must have the same dimensions. + * \return the inner product. + */ + Real dot(const Matrix& other) const { + assertSameSize(other); + + return std::inner_product(cbegin(), cend(), other.cbegin(), Real(0)); + } + + /*! + * \brief write formatted matrix to a stream object. + * \param os stream object to write to. + * \return modified stream object. + */ + std::ostream& write(std::ostream& os) const { + for (int row = 0; row < nRows_; ++row) { + const Real* rowData = data_ + row * nCols_; + for (int col = 0; col < nCols_; ++col) { + os << std::setprecision(10) << std::setw(16) << rowData[col] << " "; + } + os << std::endl; + } + os << std::endl; + return os; + } + + /*! + * \brief transposeInPlace transposes this matrix in place. + */ + void transposeInPlace() { + transposeMemoryInPlace(begin(), end(), nCols_); + std::swap(nCols_, nRows_); + } + + /*! + * \brief clone make a new copy of this matrix by deep copying the data. + * \return the copy of this matrix. + */ + Matrix clone() const { + Matrix newMatrix = Matrix(nRows_, nCols_); + std::copy(cbegin(), cend(), newMatrix.begin()); + return newMatrix; + } + + /*! + * \brief transpose this matrix, leaving the original untouched. + * \return a transposed deep copy of this matrix. + */ + Matrix transpose() const { + Matrix copy = this->clone(); + copy.transposeInPlace(); + return copy; + } + + /*! + * \brief diagonalize diagonalize this matrix, leaving the original untouched. + * \param order how to order the (eigenvalue,eigenvector) pairs, where the sort key is the real part of the + * eigenvalue. + * \return a tuple of sorted + * according to the order variable. The eigenvectors are stored by column. + */ + std::tuple, Matrix, Matrix> diagonalize(SortOrder order = SortOrder::Ascending) const { + if (nRows_ != nCols_) throw std::runtime_error("Attempting to diagonalize a non-square matrix."); + Matrix evalsReal(nRows_, 1); + Matrix evalsImag(nRows_, 1); + Matrix evecs(nRows_, nRows_); + std::vector clone(data_, data_ + nRows_ * nCols_); + + int info; + Real workDim; + LapackWrapper::diagonalizer()('V', 'N', nRows_, clone.data(), nCols_, evalsReal.data_, evalsImag.data_, + evecs.data_, nCols_, nullptr, 1, &workDim, -1, &info); + int scratchSize = static_cast(workDim); + std::vector work(scratchSize); + LapackWrapper::diagonalizer()('V', 'N', nRows_, clone.data(), nCols_, evalsReal.data_, evalsImag.data_, + evecs.data_, nCols_, nullptr, 1, work.data(), scratchSize, &info); + if (info) throw std::runtime_error("Something went wrong during diagonalization!"); + + struct eigenInfo { + Real valueReal, valueImag, *vector; + eigenInfo(Real r, Real i, Real* v) : valueReal(r), valueImag(i), vector(v) {} + bool operator<(eigenInfo const& other) const { return valueReal < other.valueReal; } + }; + + std::vector eigenTuples; + for (int val = 0; val < nRows_; ++val) + eigenTuples.push_back(eigenInfo(evalsReal[val][0], evalsImag[val][0], evecs[val])); + + std::sort(eigenTuples.begin(), eigenTuples.end()); + if (order == SortOrder::Descending) std::reverse(eigenTuples.begin(), eigenTuples.end()); + for (int val = 0; val < nRows_; ++val) { + const auto& e = eigenTuples[val]; + evalsReal.data_[val] = e.valueReal; + evalsImag.data_[val] = e.valueImag; + std::copy(e.vector, e.vector + nCols_, clone.data() + val * nCols_); + } + std::copy(clone.begin(), clone.end(), evecs.begin()); + evecs.transposeInPlace(); + return std::make_tuple(std::move(evalsReal), std::move(evalsImag), std::move(evecs)); + } +}; + +/*! + * A helper function to allow printing of Matrix objects to a stream. + */ +template +std::ostream& operator<<(std::ostream& os, Matrix const& m) { + return m.write(os); +} + +} // Namespace libpme +#endif // Header guard +// #include "memory.h" + +// original file: ../src/powers.h + +// BEGINLICENSE +// +// This file is part of libpme, which is distributed under the BSD 3-clause license, +// as described in the LICENSE file in the top level directory of this project. +// +// Author: Andrew C. Simmonett +// +// ENDLICENSE +#ifndef _LIBPME_POWERS_H_ +#define _LIBPME_POWERS_H_ + +#include + +/*! + * \file powers.h + * \brief Contains template functions to compute various quantities raised to an integer power. + */ + +namespace libpme { + +template +struct raiseToIntegerPower { + static Real pow(Real val) { return val * raiseToIntegerPower::pow(val); } +}; + +/// Base recursion for the power. +template +struct raiseToIntegerPower { + static Real pow(Real) { return 1; } +}; + +/// n is positive and even case +template +struct normIntegerPowerComputer { + static Real compute(Real val) { return raiseToIntegerPower::pow(val); } +}; + +/// n is positive and odd case +template +struct normIntegerPowerComputer { + static Real compute(Real val) { return raiseToIntegerPower::pow(std::sqrt(val)); } +}; + +/// n is negative and even case +template +struct normIntegerPowerComputer { + static Real compute(Real val) { return raiseToIntegerPower::pow(1 / val); } +}; + +/// n is negative and odd case +template +struct normIntegerPowerComputer { + static Real compute(Real val) { return raiseToIntegerPower::pow(1 / sqrt(val)); } +}; + +/*! + * \brief Compute a quantity exponentiated by an integer power, using multiplication, + * at compile time. The exponent is assumed to be positve. + * \tparam Real the floating point type to use for arithmetic. + * \tparam n the exponent to raise the value to. + */ +template +struct raiseNormToIntegerPower { + /*! + * \brief pow compute the norm raised to the power n. + * \param val the square of the norm to be exponentiated. + * \return the norm raised to the integer power. + */ + static Real compute(Real val) { return normIntegerPowerComputer= 0), (n % 2 == 0)>::compute(val); } +}; +} // Namespace libpme + +#endif // Header guard +// original file: ../src/splines.h + +// BEGINLICENSE +// +// This file is part of libpme, which is distributed under the BSD 3-clause license, +// as described in the LICENSE file in the top level directory of this project. +// +// Author: Andrew C. Simmonett +// +// ENDLICENSE +#ifndef _LIBPME_SPLINES_H_ +#define _LIBPME_SPLINES_H_ + +// #include "matrix.h" + +/*! + * \file splines.h + * \brief Contains the C++ implementation of a cardinal B-Splines. + */ + +namespace libpme { + +/*! + * \class BSpline + * \brief A class to compute cardinal B-splines. This code can compute arbitrary-order B-splines of + * arbitrary derivative level, subject to the usual constraint that an order m spline is + * differentiable m-2 times. + * \tparam Real the floating point type to use for arithmetic. + */ +template +class BSpline { + protected: + /// The order of this B-spline. + short order_; + /// The maximum derivative level for this B-spline. + short derivativeLevel_; + /// B-Splines with rows corresponding to derivative level, and columns to spline component. + Matrix splines_; + /// The grid point at which to start interpolation. + short startingGridPoint_; + + /// Makes B-Spline array. + void makeSplineInPlace(Real *array, Real val, short n) { + Real denom = (Real)1 / (n - 1); + array[n - 1] = denom * val * array[n - 2]; + for (short j = 1; j < n - 1; ++j) + array[n - j - 1] = denom * ((val + j) * array[n - j - 2] + (n - j - val) * array[n - j - 1]); + array[0] *= denom * (1 - val); + } + + /// Takes BSpline derivative. + void differentiateSpline(const Real *array, Real *dArray, short n) { + dArray[0] = -array[0]; + for (short j = 1; j < n - 1; ++j) dArray[j] = array[j - 1] - array[j]; + dArray[n - 1] = array[n - 2]; + } + + public: + /// The B-splines and their derivatives + BSpline(short start, Real value, short order, short derivativeLevel) + : order_(order), + derivativeLevel_(derivativeLevel), + splines_(derivativeLevel + 1, order), + startingGridPoint_(start) { + splines_.setZero(); + splines_(0, 0) = 1 - value; + splines_(0, 1) = value; + for (short m = 1; m < order - 1; ++m) { + makeSplineInPlace(splines_[0], value, m + 2); + if (m >= order - derivativeLevel_ - 2) { + short currentDerivative = order_ - m - 2; + for (short l = 0; l < currentDerivative; ++l) + differentiateSpline(splines_[l], splines_[l + 1], m + 2 + currentDerivative); + } + } + } + + BSpline() {} + + /*! + * \brief The modulus of the B-Spline in Fourier space. + * \param gridDim the dimension of the grid in the dimension this spline is to be used. + * \return a gridDim long vector containing the inverse of the Fourier space spline moduli. + */ + std::vector invSplineModuli(short gridDim) { + std::vector splineMods(gridDim, 0); + Real prefac = 2.0 * M_PI / gridDim; + for (int i = 0; i < gridDim; ++i) { + Real real = 0.0; + Real imag = 0.0; + for (int j = 0; j < order_; ++j) { + Real exparg = i * j * prefac; + Real jSpline = splines_(0, j); + real += jSpline * cos(exparg); + imag += jSpline * sin(exparg); + } + splineMods[i] = real * real + imag * imag; + } + + // Correct tiny values. + constexpr Real EPS = 1e-7; + if (splineMods[0] < EPS) splineMods[0] = 0.5 * splineMods[1]; + for (int i = 0; i < gridDim - 1; ++i) + if (splineMods[i] < EPS) splineMods[i] = 0.5 * (splineMods[i - 1] + splineMods[i + 1]); + if (splineMods[gridDim - 1] < EPS) splineMods[gridDim - 1] = 0.5 * splineMods[gridDim - 2]; + + // Invert, to avoid division later on. + for (int i = 0; i < gridDim; ++i) splineMods[i] = 1.0 / splineMods[i]; + return splineMods; + } + + /*! + * \brief Gets the grid point to start interpolating from. + * \return the index of the first grid point this spline supports. + */ + short startingGridPoint() const { return startingGridPoint_; } + + /*! + * \brief Returns the B-Spline, or derivative thereof. + * \param deriv the derivative level of the spline to be returned. + */ + const Real *operator[](short deriv) const { return splines_[deriv]; } + + /*! + * \brief Get read-only access to the full spline data. + * \returns a const reference to the full spline data: row index is derivative, col index is spline component. + */ + const Matrix &splineData() const { return splines_; } +}; + +} // Namespace libpme +#endif // Header guard + +/*! + * \file libpme.h + * \brief Contains the C++ implementation of a PME Instance, and related helper classes. + */ + +namespace libpme { + +/* + * FFTW likes to have transformations with dimensions of the form + * + * a b c d e f + * 2 3 5 7 11 13 + * + * where a,b,c and d are general and e+f is either 0 or 1. Here is a tabulation + * of all numbers up to 10000 that fit such a pattern. MKL has similar demands: + * + * https://software.intel.com/en-us/articles/fft-length-and-layout-advisor/ + * http://www.fftw.org/fftw3_doc/Real_002ddata-DFTs.html + */ +static constexpr short maxGridDim = 10000; +static constexpr short idealGridDims[337] = { + 1, 2, 3, 4, 5, 6, 8, 9, 10, 11, 12, 13, 15, 16, 18, 20, 22, 24, 25, + 26, 27, 30, 32, 33, 36, 39, 40, 44, 45, 48, 50, 52, 54, 55, 60, 64, 65, 66, + 72, 75, 78, 80, 81, 88, 90, 96, 99, 100, 104, 108, 110, 117, 120, 125, 128, 130, 132, + 135, 144, 150, 156, 160, 162, 165, 176, 180, 192, 195, 198, 200, 208, 216, 220, 225, 234, 240, + 243, 250, 256, 260, 264, 270, 275, 288, 297, 300, 312, 320, 324, 325, 330, 351, 352, 360, 375, + 384, 390, 396, 400, 405, 416, 432, 440, 450, 468, 480, 486, 495, 500, 512, 520, 528, 540, 550, + 576, 585, 594, 600, 624, 625, 640, 648, 650, 660, 675, 702, 704, 720, 729, 750, 768, 780, 792, + 800, 810, 825, 832, 864, 880, 891, 900, 936, 960, 972, 975, 990, 1000, 1024, 1040, 1053, 1056, 1080, + 1100, 1125, 1152, 1170, 1188, 1200, 1215, 1248, 1250, 1280, 1296, 1300, 1320, 1350, 1375, 1404, 1408, 1440, 1458, + 1485, 1500, 1536, 1560, 1584, 1600, 1620, 1625, 1650, 1664, 1728, 1755, 1760, 1782, 1800, 1872, 1875, 1920, 1944, + 1950, 1980, 2000, 2025, 2048, 2080, 2106, 2112, 2160, 2187, 2200, 2250, 2304, 2340, 2376, 2400, 2430, 2475, 2496, + 2500, 2560, 2592, 2600, 2640, 2673, 2700, 2750, 2808, 2816, 2880, 2916, 2925, 2970, 3000, 3072, 3120, 3125, 3159, + 3168, 3200, 3240, 3250, 3300, 3328, 3375, 3456, 3510, 3520, 3564, 3600, 3645, 3744, 3750, 3840, 3888, 3900, 3960, + 4000, 4050, 4096, 4125, 4160, 4212, 4224, 4320, 4374, 4400, 4455, 4500, 4608, 4680, 4752, 4800, 4860, 4875, 4950, + 4992, 5000, 5120, 5184, 5200, 5265, 5280, 5346, 5400, 5500, 5616, 5625, 5632, 5760, 5832, 5850, 5940, 6000, 6075, + 6144, 6240, 6250, 6318, 6336, 6400, 6480, 6500, 6561, 6600, 6656, 6750, 6875, 6912, 7020, 7040, 7128, 7200, 7290, + 7425, 7488, 7500, 7680, 7776, 7800, 7920, 8000, 8019, 8100, 8125, 8192, 8250, 8320, 8424, 8448, 8640, 8748, 8775, + 8800, 8910, 9000, 9216, 9360, 9375, 9477, 9504, 9600, 9720, 9750, 9900, 9984, 10000}; + +/*! + * \brief nCartesian computes the total number of Cartesian components of a given angular momentum. + * \param L the angular momentum. + * \return total number of components up to and including angular momentum L. + */ +static int nCartesian(int L) { return (L + 1) * (L + 2) * (L + 3) / 6; } + +/*! + * \brief cartAddress computes the address of a term with given quantum numbers in a Cartesian buffer. + * \param lx the x quantum number. + * \param ly the y quantum number. + * \param lz the z quantum number. + * \return the address of an {lx, ly, lz} quantity in a buffer that contains all lower angular momentum terms too. + */ +static int cartAddress(int lx, int ly, int lz) { + int l = lx + ly + lz; + return l * (l + 1) * (l + 2) / 6 + lz * (l * 2 - lz + 3) / 2 + ly; +} + +// This is used to define function pointers in the constructor, and makes it easy to add new kernels. +#define ENABLE_KERNEL_WITH_INVERSE_R_EXPONENT_OF(n) \ + case n: \ + convolveEFxn_ = &convolveEImpl; \ + convolveEVFxn_ = &convolveEVImpl; \ + slfEFxn_ = &slfEImpl; \ + dirEFxn_ = &dirEImpl; \ + adjEFxn_ = &adjEImpl; \ + dirEFFxn_ = &dirEFImpl; \ + adjEFFxn_ = &adjEFImpl; \ + break; + +/*! + * \class PMEInstance + * \brief A class to encapsulate information related to a particle mesh Ewald calculation. + * + * By storing information related to a single PME calculation in this way, we allow multiple + * instances to be created in calculations requiring multiple PMEs, e.g. for computing both + * electrostatic and attractive dispersion terms using PME to handle long-range interactions. + * \tparam Real the floating point type to use for arithmetic. + */ +template +class PMEInstance { + using GridIterator = std::vector>>; + + protected: + /// The FFT grid dimensions in the {A,B,C} grid dimensions. + int aDim_, bDim_, cDim_; + /// The X dimension after real->complex transformation. + int xDim_; + /// The order of the cardinal B-Spline used for interpolation. + int splineOrder_; + /// The number of threads per MPI instance. + int nThreads_; + /// The scale factor to apply to all energies and derivatives. + Real scaleFactor_; + /// The attenuation parameter, whose units should be the inverse of those used to specify coordinates. + Real kappa_; + /// The lattice vectors. + Matrix boxVecs_; + /// The reciprocal lattice vectors. + Matrix recVecs_; + /// The scaled reciprocal lattice vectors, for transforming forces from scaled fractional coordinates. + Matrix scaledRecVecs_; + /// An iterator over angular momentum components. + std::vector> angMomIterator_; + /// The number of permutations of each multipole component. + std::vector permutations_; + /// From a given starting point on the {A,B,C} edge of the grid, lists all points to be handled, correctly wrapping + /// around the end. + GridIterator aGridIterator_, bGridIterator_, cGridIterator_; + /// The real-space (density, potential) grid. + Matrix realGrid_; + /// The Fourier space transformed grid, in {x,y,z} pencil form. + Matrix> compGridCXB_, compGridCBX_, compGridXYC_, compGridXYZ_; + /// The (inverse) bspline moduli to normalize the spreading / probing steps; these are folded into the convolution. + std::vector aSplineMod_, bSplineMod_, cSplineMod_; + /// A function pointer to call the approprate function to implement convolution, templated to the rPower value. + std::function> &, const Matrix &, Real, Real, + const std::vector &, const std::vector &, const std::vector &, int, + const Matrix &)> + convolveEFxn_; + /// A function pointer to call the approprate function to implement convolution with virial, templated to + /// the rPower value. + std::function> &, const Matrix &, Real, Real, + const std::vector &, const std::vector &, const std::vector &, int, + const Matrix &, Matrix &)> + convolveEVFxn_; + /// A function pointer to call the approprate function to compute self energy, templated to the rPower value. + std::function &, Real, Real)> slfEFxn_; + /// A function pointer to call the approprate function to compute the direct energy, templated to the rPower value. + std::function dirEFxn_; + /// A function pointer to call the approprate function to compute the adjusted energy, templated to the rPower + /// value. + std::function adjEFxn_; + /// A function pointer to call the approprate function to compute the direct energy and force, templated to the + /// rPower value. + std::function(Real, Real, Real)> dirEFFxn_; + /// A function pointer to call the approprate function to compute the adjusted energy and force, templated to the + /// rPower value. + std::function(Real, Real, Real)> adjEFFxn_; + /// The rank of this node along the {X,Y,Z} dimensions. + int rankX_, rankY_, rankZ_; + /// The first grid point that this node is responsible for in the {X,Y,Z} dimensions. + int firstX_, firstY_, firstZ_; + /// The grid point beyond the last point that this this node is responsible for in the {X,Y,Z} dimensions. + int lastX_, lastY_, lastZ_; + /// The {X,Y,Z} dimensions of the locally owned chunk of the grid. + int myDimX_, myDimY_, myDimZ_; + /// FFTW wrappers to help with transformations in the three dimensions. + FFTWWrapper fftHelperA_, fftHelperB_, fftHelperC_; + + /*! + * \brief A simple helper to compute factorials. + * \param n the number whose factorial is to be taken. + * \return n! + */ + unsigned int factorial(unsigned int n) { + unsigned int ret = 1; + for (unsigned int i = 1; i <= n; ++i) ret *= i; + return ret; + } + + /*! Make sure that the iterator over AM components is up to date. + * \param angMom the angular momentum required for the iterator over multipole components. + */ + void updateAngMomIterator(int parameterAngMom) { + auto L = parameterAngMom; + size_t expectedNTerms = nCartesian(L); + if (angMomIterator_.size() >= expectedNTerms) return; + + angMomIterator_.resize(expectedNTerms); + permutations_.resize(expectedNTerms); + for (short l = 0, count = 0; l <= L; ++l) { + for (short lz = 0; lz <= l; ++lz) { + for (short ly = 0; ly <= l - lz; ++ly) { + short lx = l - ly - lz; + angMomIterator_[count] = {{static_cast(lx), static_cast(ly), static_cast(lz)}}; + permutations_[count] = (Real)factorial(l) / (factorial(lx) * factorial(ly) * factorial(lz)); + ++count; + } + } + } + } + + /*! + * \brief makeBSplines construct the {x,y,z} B-Splines. + * \param atomCoords a 3-vector containing the atom's coordinates. + * \param derivativeLevel level of derivative needed for the splines. + * \return a 3-tuple containing the {x,y,z} B-splines. + */ + std::tuple, BSpline, BSpline> makeBSplines(const Real *atomCoords, + short derivativeLevel) { + // Subtract a tiny amount to make sure we're not exactly on the rightmost (excluded) + // grid point. The calculation is translationally invariant, so this is valid. + constexpr float EPS = 1e-6; + Real aCoord = + atomCoords[0] * recVecs_(0, 0) + atomCoords[1] * recVecs_(1, 0) + atomCoords[2] * recVecs_(2, 0) - EPS; + Real bCoord = + atomCoords[0] * recVecs_(0, 1) + atomCoords[1] * recVecs_(1, 1) + atomCoords[2] * recVecs_(2, 1) - EPS; + Real cCoord = + atomCoords[0] * recVecs_(0, 2) + atomCoords[1] * recVecs_(1, 2) + atomCoords[2] * recVecs_(2, 2) - EPS; + // Make sure the fractional coordinates fall in the range 0 <= s < 1 + aCoord -= floor(aCoord); + bCoord -= floor(bCoord); + cCoord -= floor(cCoord); + short aStartingGridPoint = aDim_ * aCoord; + short bStartingGridPoint = bDim_ * bCoord; + short cStartingGridPoint = cDim_ * cCoord; + Real aDistanceFromGridPoint = aDim_ * aCoord - aStartingGridPoint; + Real bDistanceFromGridPoint = bDim_ * bCoord - bStartingGridPoint; + Real cDistanceFromGridPoint = cDim_ * cCoord - cStartingGridPoint; + return std::make_tuple( + BSpline(aStartingGridPoint, aDistanceFromGridPoint, splineOrder_, derivativeLevel), + BSpline(bStartingGridPoint, bDistanceFromGridPoint, splineOrder_, derivativeLevel), + BSpline(cStartingGridPoint, cDistanceFromGridPoint, splineOrder_, derivativeLevel)); + } + + /*! + * \brief sanityChecks just makes sure that inputs have consistent dimensions, and that prerequisites are + * initialized. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for + * quadrupoles, etc.). + * \param parameters the input parameters. + * \param coordinates the input coordinates. + */ + void sanityChecks(int parameterAngMom, const Matrix ¶meters, const Matrix &coordinates) { + // Start with some sanity checks. + if (parameters.nRows() == 0) + throw std::runtime_error("Parameters have not been set yet! Call setParameters(...) before runPME(...);"); + if (coordinates.nRows() == 0) + throw std::runtime_error( + "Coordinates have not been set yet! Call setCoordinates(...) before runPME(...);"); + if (boxVecs_.isNearZero()) + throw std::runtime_error( + "Lattice vectors have not been set yet! Call setLatticeVectors(...) before runPME(...);"); + if (coordinates.nRows() != parameters.nRows()) + throw std::runtime_error( + "Inconsistent number of coordinates and parameters; there should be nAtoms of each."); + if (parameters.nCols() != nCartesian(parameterAngMom)) + throw std::runtime_error( + "Mismatch in the number of parameters provided and the parameter angular momentum"); + } + + /*! + * \brief convolveEImpl performs the reciprocal space convolution, returning the energy + * \tparam rPower the exponent of the (inverse) distance kernel (e.g. 1 for Coulomb, 6 for attractive dispersion). + * \param nx the grid dimension in the x direction. + * \param ny the grid dimension in the y direction. + * \param nz the grid dimension in the z direction. + * \param scaleFactor a scale factor to be applied to all computed energies and derivatives thereof (e.g. the 1 / [4 + * pi epslion0] for Coulomb calculations). + * \param grid the Fourier space grid. + * \param boxInv the reciprocal lattice vectors. + * \param volume the volume of the unit cell. + * \param kappa the attenuation parameter in units inverse of those used to specify coordinates. + * \param xMods the Fourier space norms of the x B-Splines. + * \param yMods the Fourier space norms of the y B-Splines. + * \param zMods the Fourier space norms of the z B-Splines. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \return the reciprocal space energy. + */ + template + static Real convolveEImpl(int nx, int ny, int nz, Real scaleFactor, Matrix> &grid, + const Matrix &boxInv, Real volume, Real kappa, const std::vector &xMods, + const std::vector &yMods, const std::vector &zMods, int parameterAngMom, + const Matrix ¶meters) { + Real energy = 0; + std::vector xMVals(nx), yMVals(ny), zMVals(nz); + // Iterators to conveniently map {X,Y,Z} grid location to m_{X,Y,Z} value, where -1/2 << m/dim < 1/2. + for (int kx = 0; kx < nx; ++kx) xMVals[kx] = kx >= (nx + 1) / 2 ? kx - nx : kx; + for (int ky = 0; ky < ny; ++ky) yMVals[ky] = ky >= (ny + 1) / 2 ? ky - ny : ky; + for (int kz = 0; kz < nz; ++kz) zMVals[kz] = kz >= (nz + 1) / 2 ? kz - nz : kz; + + Real bPrefac = M_PI * M_PI / (kappa * kappa); + Real volPrefac = scaleFactor * pow(M_PI, rPower - 1) / (sqrtPi * gammaComputer::value * volume); + int halfNx = nx / 2 + 1; + std::complex *gridPtr = grid[0]; + for (int kx = 0; kx < halfNx; ++kx) { + // Exclude m=0 cell. + size_t start = kx == 0 ? 1 : 0; + // We only loop over the first nx/2+1 x values; this accounts for the "missing" complex conjugate values. + Real permPrefac = kx != 0 && kx != halfNx - 1 ? 2 : 1; + size_t nyz = ny * nz; + std::complex *xPtr = gridPtr + kx * nyz; + Real mx = (Real)xMVals[kx]; + Real xMod = xMods[kx]; + for (size_t yz = start; yz < nyz; ++yz) { + int ky = yz / nz; + int kz = yz % nz; + Real my = (Real)yMVals[ky]; + Real mz = (Real)zMVals[kz]; + // TODO clean this up and move stuff up into outer loops. + Real mVecX = boxInv(0, 0) * mx + boxInv(0, 1) * my + boxInv(0, 2) * mz; + Real mVecY = boxInv(1, 0) * mx + boxInv(1, 1) * my + boxInv(1, 2) * mz; + Real mVecZ = boxInv(2, 0) * mx + boxInv(2, 1) * my + boxInv(2, 2) * mz; + Real mNormSq = mVecX * mVecX + mVecY * mVecY + mVecZ * mVecZ; + Real mTerm = raiseNormToIntegerPower::compute(mNormSq); + Real bSquared = bPrefac * mNormSq + std::numeric_limits::epsilon(); + Real incompleteGammaTerm = incompleteGammaComputer::compute(bSquared); + std::complex &gridVal = xPtr[ky * nz + kz]; + Real structFacNorm = std::norm(gridVal); + Real influenceFunction = volPrefac * incompleteGammaTerm * mTerm * xMod * yMods[ky] * zMods[kz]; + gridVal *= influenceFunction; + energy += permPrefac * influenceFunction * structFacNorm; + } + } + energy /= 2; + + if (rPower > 3) { + // Kernels with rPower>3 are absolutely convergent and should have the m=0 term present. + size_t nAtoms = parameters.nRows(); + Real prefac = scaleFactor * M_PI * sqrtPi * pow(kappa, rPower - 3) / + ((rPower - 3) * gammaComputer::value * volume); + // To compute it we need sum_ij c(i)c(j); here's a way to do in O(N) effort instead of O(N^2). + Real sumI = 0; + Real sumIJ = 0; + for (int i = 0; i < nAtoms; ++i) sumI += parameters(i, 0); + for (int j = 0; j < nAtoms; ++j) sumIJ += sumI * parameters(j, 0); + energy += prefac * sumIJ; + } + + return energy; + } + + /*! + * \brief convolveEVImpl performs the reciprocal space convolution, returning the energy + * \tparam rPower the exponent of the (inverse) distance kernel (e.g. 1 for Coulomb, 6 for attractive dispersion). + * \param nx the grid dimension in the x direction. + * \param ny the grid dimension in the y direction. + * \param nz the grid dimension in the z direction. + * \param scaleFactor a scale factor to be applied to all computed energies and derivatives thereof (e.g. the 1 / [4 + * pi epslion0] for Coulomb calculations). + * \param grid the Fourier space grid. + * \param boxInv the reciprocal lattice vectors. + * \param volume the volume of the unit cell. + * \param kappa the attenuation parameter in units inverse of those used to specify coordinates. + * \param xMods the Fourier space norms of the x B-Splines. + * \param yMods the Fourier space norms of the y B-Splines. + * \param zMods the Fourier space norms of the z B-Splines. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param virial a vector of length 6 containing the unique virial elements, in the order XX XY YY XZ YZ ZZ. + * This vector is incremented, not assigned. + * \return the reciprocal space energy. + */ + template + static Real convolveEVImpl(int nx, int ny, int nz, Real scaleFactor, Matrix> &grid, + const Matrix &boxInv, Real volume, Real kappa, const std::vector &xMods, + const std::vector &yMods, const std::vector &zMods, int parameterAngMom, + const Matrix ¶meters, Matrix &virial) { + Real energy = 0; + std::vector xMVals(nx), yMVals(ny), zMVals(nz); + // Iterators to conveniently map {X,Y,Z} grid location to m_{X,Y,Z} value, where -1/2 << m/dim < 1/2. + for (int kx = 0; kx < nx; ++kx) xMVals[kx] = kx >= (nx + 1) / 2 ? kx - nx : kx; + for (int ky = 0; ky < ny; ++ky) yMVals[ky] = ky >= (ny + 1) / 2 ? ky - ny : ky; + for (int kz = 0; kz < nz; ++kz) zMVals[kz] = kz >= (nz + 1) / 2 ? kz - nz : kz; + + Real bPrefac = M_PI * M_PI / (kappa * kappa); + Real volPrefac = scaleFactor * pow(M_PI, rPower - 1) / (sqrtPi * gammaComputer::value * volume); + int halfNx = nx / 2 + 1; + Real Vxx = 0; + Real Vxy = 0; + Real Vyy = 0; + Real Vxz = 0; + Real Vyz = 0; + Real Vzz = 0; + std::complex *gridPtr = grid[0]; + for (int kx = 0; kx < halfNx; ++kx) { + // Exclude m=0 cell. + size_t start = kx == 0 ? 1 : 0; + // We only loop over the first nx/2+1 x values; this accounts for the "missing" complex conjugate values. + Real permPrefac = kx != 0 && kx != halfNx - 1 ? 2 : 1; + size_t nyz = ny * nz; + std::complex *xPtr = gridPtr + kx * nyz; + Real mx = (Real)xMVals[kx]; + Real xMod = xMods[kx]; + for (size_t yz = start; yz < nyz; ++yz) { + int ky = yz / nz; + int kz = yz % nz; + Real my = (Real)yMVals[ky]; + Real mz = (Real)zMVals[kz]; + Real mVecX = boxInv(0, 0) * mx + boxInv(0, 1) * my + boxInv(0, 2) * mz; + Real mVecY = boxInv(1, 0) * mx + boxInv(1, 1) * my + boxInv(1, 2) * mz; + Real mVecZ = boxInv(2, 0) * mx + boxInv(2, 1) * my + boxInv(2, 2) * mz; + Real mNormSq = mVecX * mVecX + mVecY * mVecY + mVecZ * mVecZ; + Real mTerm = raiseNormToIntegerPower::compute(mNormSq); + Real bSquared = bPrefac * mNormSq; + auto gammas = incompleteGammaVirialComputer::compute(bSquared); + Real eGamma = std::get<0>(gammas); + Real vGamma = std::get<1>(gammas); + std::complex &gridVal = xPtr[ky * nz + kz]; + Real structFacNorm = std::norm(gridVal); + Real totalPrefac = volPrefac * mTerm * xMod * yMods[ky] * zMods[kz]; + Real influenceFunction = totalPrefac * eGamma; + gridVal *= influenceFunction; + Real eTerm = permPrefac * influenceFunction * structFacNorm; + Real vTerm = permPrefac * vGamma * totalPrefac / mNormSq * structFacNorm; + energy += eTerm; + Vxx += vTerm * mVecX * mVecX; + Vxy += vTerm * mVecX * mVecY; + Vyy += vTerm * mVecY * mVecY; + Vxz += vTerm * mVecX * mVecZ; + Vyz += vTerm * mVecY * mVecZ; + Vzz += vTerm * mVecZ * mVecZ; + } + } + energy /= 2; + + if (rPower > 3) { + // Kernels with rPower>3 are absolutely convergent and should have the m=0 term present. + size_t nAtoms = parameters.nRows(); + Real prefac = scaleFactor * M_PI * sqrtPi * pow(kappa, rPower - 3) / + ((rPower - 3) * gammaComputer::value * volume); + // To compute it we need sum_ij c(i)c(j); here's a way to do in O(N) effort instead of O(N^2). + Real sumI = 0; + Real sumIJ = 0; + for (int i = 0; i < nAtoms; ++i) sumI += parameters(i, 0); + for (int j = 0; j < nAtoms; ++j) sumIJ += sumI * parameters(j, 0); + energy += prefac * sumIJ; + } + + virial[0][0] -= Vxx - energy; + virial[0][1] -= Vxy; + virial[0][2] -= Vyy - energy; + virial[0][3] -= Vxz; + virial[0][4] -= Vyz; + virial[0][5] -= Vzz - energy; + + return energy; + } + + /*! + * \brief dirEImpl computes the kernel for the direct energy for a pair. + * \tparam rPower the exponent of the (inverse) distance kernel (e.g. 1 for Coulomb, 6 for attractive dispersion). + * \param rSquared the square of the internuclear distance + * \param kappaSquared the square of attenuation parameter in units inverse of those used to specify coordinates. + * \return the energy kernel. + */ + template + inline static Real dirEImpl(Real rSquared, Real kappaSquared) { + Real denominator = raiseNormToIntegerPower::compute(rSquared); + Real gammaTerm = incompleteGammaComputer::compute(rSquared * kappaSquared) / + gammaComputer::value; + return gammaTerm / denominator; + } + + /*! + * \brief dirEFImpl computes the kernels for the direct energy and force for a pair. + * \tparam rPower the exponent of the (inverse) distance kernel (e.g. 1 for Coulomb, 6 for attractive dispersion). + * \param rSquared the square of the internuclear distance + * \param kappa the attenuation parameter in units inverse of those used to specify coordinates. + * \param kappaSquared the square of attenuation parameter in units inverse of those used to specify coordinates. + * \return a tuple containing the energy and force kernels, respectively. + */ + template + inline static std::tuple dirEFImpl(Real rSquared, Real kappa, Real kappaSquared) { + Real rInv = 1 / rSquared; + Real kappaToRPower = kappa; + for (int i = 1; i < rPower; ++i) kappaToRPower *= kappa; + Real denominator = raiseNormToIntegerPower::compute(rSquared); + Real gammaTerm = incompleteGammaComputer::compute(rSquared * kappaSquared) / + gammaComputer::value; + Real eKernel = gammaTerm / denominator; + Real fKernel = -rPower * eKernel * rInv - + 2 * rInv * exp(-kappaSquared * rSquared) * kappaToRPower / gammaComputer::value; + return std::make_tuple(eKernel, fKernel); + } + + /*! + * \brief adjEImpl computes the kernel for the adjusted energy for a pair. + * \tparam rPower the exponent of the (inverse) distance kernel (e.g. 1 for Coulomb, 6 for attractive dispersion). + * \param rSquared the square of the internuclear distance + * \param kappaSquared the square of attenuation parameter in units inverse of those used to specify coordinates. + * \return the energy kernel. + */ + template + inline static Real adjEImpl(Real rSquared, Real kappaSquared) { + Real denominator = raiseNormToIntegerPower::compute(rSquared); + Real gammaTerm = incompleteGammaComputer::compute(rSquared * kappaSquared) / + gammaComputer::value; + return (gammaTerm - 1) / denominator; + } + + /*! + * \brief adjEFImpl computes the kernels for the adjusted energy and force for a pair. + * \tparam rPower the exponent of the (inverse) distance kernel (e.g. 1 for Coulomb, 6 for attractive dispersion). + * \param rSquared the square of the internuclear distance + * \param kappa the attenuation parameter in units inverse of those used to specify coordinates. + * \param kappaSquared the square of attenuation parameter in units inverse of those used to specify coordinates. + * \return a tuple containing the energy and force kernels, respectively. + */ + template + inline static std::tuple adjEFImpl(Real rSquared, Real kappa, Real kappaSquared) { + Real rInv = 1 / rSquared; + Real kappaToRPower = kappa; + for (int i = 1; i < rPower; ++i) kappaToRPower *= kappa; + Real denominator = raiseNormToIntegerPower::compute(rSquared); + Real gammaTerm = incompleteGammaComputer::compute(rSquared * kappaSquared) / + gammaComputer::value; + Real eKernel = (gammaTerm - 1) / denominator; + Real fKernel = -rPower * eKernel * rInv - + 2 * rInv * exp(-kappaSquared * rSquared) * kappaToRPower / gammaComputer::value; + return std::make_tuple(eKernel, fKernel); + } + + /*! + * \brief slfEImpl computes the self energy due to particles feeling their own potential. + * \tparam rPower the exponent of the (inverse) distance kernel (e.g. 1 for Coulomb, 6 for attractive dispersion). + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param kappa the attenuation parameter in units inverse of those used to specify coordinates. + * \param scaleFactor a scale factor to be applied to all computed energies and derivatives thereof (e.g. the 1 / [4 + * pi epslion0] for Coulomb calculations). + * \return the self energy. N.B. there is no self force associated with this term. + */ + template + static Real slfEImpl(int parameterAngMom, const Matrix ¶meters, Real kappa, Real scaleFactor) { + if (parameterAngMom) throw std::runtime_error("Multipole self terms have not been coded yet."); + + size_t nAtoms = parameters.nRows(); + Real prefac = -scaleFactor * std::pow(kappa, rPower) / (rPower * gammaComputer::value); + Real sumCoefs = 0; + for (size_t atom = 0; atom < nAtoms; ++atom) { + sumCoefs += parameters(atom, 0) * parameters(atom, 0); + } + return prefac * sumCoefs; + } + + public: + /*! + * \brief The different conventions for orienting a lattice constructed from input parameters. + */ + enum class LatticeType : int { XAligned = 0, ShapeMatrix = 1 }; + + /*! + * \brief The different conventions for numbering nodes. + */ + enum class NodeOrder : int { ZYX = 0 }; + + /*! + * \brief Returns a read-only copy of the real space grid. + * + * This grid contains the density after spreadParameters() has been called, then + * the potential after the FFTs and convolution step. + */ + const Matrix &realGrid() { return realGrid_; } + + /*! + * \brief Returns a read-only copy of the Fourier space forward transformed grid. + * + * This grid contains the Fourier transformed density and should not generally + * be accessed for any reason other than for testing purposes. + */ + const Matrix> &compGridXYZ() { return compGridXYZ_; } + + PMEInstance() : boxVecs_(3, 3), recVecs_(3, 3), scaledRecVecs_(3, 3) {} + + /*! + * \brief cellVolume Compute the volume of the unit cell. + * \return volume in units consistent with those used to define the lattice vectors. + */ + Real cellVolume() { + return boxVecs_(0, 0) * boxVecs_(1, 1) * boxVecs_(2, 2) - boxVecs_(0, 0) * boxVecs_(1, 2) * boxVecs_(2, 1) + + boxVecs_(0, 1) * boxVecs_(1, 2) * boxVecs_(2, 0) - boxVecs_(0, 1) * boxVecs_(1, 0) * boxVecs_(2, 2) + + boxVecs_(0, 2) * boxVecs_(1, 0) * boxVecs_(2, 1) - boxVecs_(0, 2) * boxVecs_(1, 1) * boxVecs_(2, 0); + } + + /*! + * \brief Sets the unit cell lattice vectors, with units consistent with those used to specify coordinates. + * \param A the A lattice parameter in units consistent with the coordinates. + * \param B the B lattice parameter in units consistent with the coordinates. + * \param C the C lattice parameter in units consistent with the coordinates. + * \param alpha the alpha lattice parameter in degrees. + * \param beta the beta lattice parameter in degrees. + * \param gamma the gamma lattice parameter in degrees. + * \param latticeType how to arrange the lattice vectors. Options are + * ShapeMatrix: enforce a symmetric representation of the lattice vectors [c.f. S. Nosé and M. L. Klein, + * Mol. Phys. 50 1055 (1983)] particularly appendix C. + * XAligned: make the A vector coincide with the X axis, the B vector fall in the XY plane, and the C vector + * take the appropriate alignment to completely define the system. + */ + void setLatticeVectors(Real A, Real B, Real C, Real alpha, Real beta, Real gamma, LatticeType latticeType) { + if (latticeType == LatticeType::ShapeMatrix) { + Matrix HtH(3, 3); + HtH(0, 0) = A * A; + HtH(1, 1) = B * B; + HtH(2, 2) = C * C; + // Check for angles very close to 90, to avoid noise from the eigensolver later on. + HtH(0, 1) = HtH(1, 0) = std::abs(gamma - 90) < 1e-4f ? 0 : A * B * cos(M_PI * gamma / 180); + HtH(0, 2) = HtH(2, 0) = std::abs(beta - 90) < 1e-4f ? 0 : A * C * cos(M_PI * beta / 180); + HtH(1, 2) = HtH(2, 1) = std::abs(alpha - 90) < 1e-4f ? 0 : B * C * cos(M_PI * alpha / 180); + + auto eigenTuple = HtH.diagonalize(); + Matrix evalsReal = std::get<0>(eigenTuple); + Matrix evalsImag = std::get<1>(eigenTuple); + Matrix evecs = std::get<2>(eigenTuple); + if (!evalsImag.isNearZero()) + throw std::runtime_error("Unexpected complex eigenvalues encountered while making shape matrix."); + for (int i = 0; i < 3; ++i) evalsReal(i, 0) = sqrt(evalsReal(i, 0)); + boxVecs_.setZero(); + for (int i = 0; i < 3; ++i) { + for (int j = 0; j < 3; ++j) { + for (int k = 0; k < 3; ++k) { + boxVecs_(i, j) += evecs(i, k) * evecs(j, k) * evalsReal(k, 0); + } + } + } + recVecs_ = boxVecs_.inverse(); + } else if (latticeType == LatticeType::XAligned) { + boxVecs_(0, 0) = A; + boxVecs_(0, 1) = 0; + boxVecs_(0, 2) = 0; + boxVecs_(1, 0) = B * cos(M_PI / 180 * gamma); + boxVecs_(1, 1) = B * sin(M_PI / 180 * gamma); + boxVecs_(1, 2) = 0; + boxVecs_(2, 0) = C * cos(M_PI / 180 * beta); + boxVecs_(2, 1) = (B * C * cos(M_PI / 180 * alpha) - boxVecs_(2, 0) * boxVecs_(1, 0)) / boxVecs_(1, 1); + boxVecs_(2, 2) = sqrt(C * C - boxVecs_(2, 0) * boxVecs_(2, 0) - boxVecs_(2, 1) * boxVecs_(2, 1)); + } else { + throw std::runtime_error("Unknown lattice type in setLatticeVectors"); + } + recVecs_ = boxVecs_.inverse(); + scaledRecVecs_ = recVecs_.clone(); + scaledRecVecs_.row(0) *= aDim_; + scaledRecVecs_.row(1) *= bDim_; + scaledRecVecs_.row(2) *= cDim_; + } + + /*! + * \brief Performs the forward 3D FFT. + * + * The realGrid_ member (stored in CBA order, with A being the fast running index) is + * transformed sequentially, yielding the complex grid compGridz_, which is XYZ ordered. + */ + void forwardTransform() { + // CBA -> CBX with instant sort to CXB + libpme::vector> buffer(aDim_); + auto scratch = buffer.data(); + for (int c = 0; c < cDim_; ++c) { + for (int b = 0; b < bDim_; ++b) { + int cb = c * bDim_ + b; + fftHelperA_.transform(realGrid_[cb], scratch); + for (int x = 0; x < xDim_; ++x) { + int cx = c * xDim_ + x; + compGridCXB_(cx, b) = scratch[x]; + } + } + } + + // CXB -> CXY with instant sort to XYC + for (int c = 0; c < cDim_; ++c) { + for (int x = 0; x < xDim_; ++x) { + int cx = c * xDim_ + x; + fftHelperB_.transform(compGridCXB_[cx], FFTW_FORWARD); + for (int y = 0; y < bDim_; ++y) { + int xy = x * bDim_ + y; + compGridXYC_(xy, c) = compGridCXB_[cx][y]; + } + } + } + + // XYC -> XYZ + for (int xy = 0; xy < xDim_ * bDim_; ++xy) { + fftHelperC_.transform(compGridXYC_[xy], compGridXYZ_[xy], FFTW_FORWARD); + } + } + + /*! + * \brief Performs the inverse 3D FFT. + * + * The complGridXYZ_ member (stored in XYZ order, with Z being the fast running index) is + * transformed sequentially, yielding the real grid realGrid_, which is CBA ordered. + */ + void inverseTransform() { + // XYZ -> XYC with instant sort to CXY (stored in CXB buffer) + for (int x = 0; x < xDim_; ++x) { + for (int y = 0; y < bDim_; ++y) { + int xy = x * bDim_ + y; + fftHelperC_.transform(compGridXYZ_[xy], FFTW_BACKWARD); + for (int c = 0; c < cDim_; ++c) { + int cx = c * xDim_ + x; + compGridCXB_(cx, y) = compGridXYZ_[xy][c]; + } + } + } + + // CXY->CXB with instant sort to CBX + for (int c = 0; c < cDim_; ++c) { + for (int x = 0; x < xDim_; ++x) { + int cx = c * xDim_ + x; + fftHelperB_.transform(compGridCXB_[cx], FFTW_BACKWARD); + for (int b = 0; b < bDim_; ++b) { + int cb = c * bDim_ + b; + compGridCBX_(cb, x) = compGridCXB_[cx][b]; + } + } + } + + // CBX -> CBA + for (int cb = 0; cb < cDim_ * bDim_; ++cb) { + fftHelperA_.transform(compGridCBX_[cb], realGrid_[cb]); + } + } + + /*! + * \brief convolveE A wrapper to determine the correct convolution function to call. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \return the reciprocal space energy. + */ + Real convolveE(int parameterAngMom, const Matrix ¶meters) { + return convolveEFxn_(aDim_, bDim_, cDim_, scaleFactor_, compGridXYZ_, recVecs_, cellVolume(), kappa_, + aSplineMod_, bSplineMod_, cSplineMod_, parameterAngMom, parameters); + } + + /*! + * \brief convolveEV A wrapper to determine the correct convolution function to call, including virial. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param virial a vector of length 6 containing the unique virial elements, in the order XX XY YY XZ YZ ZZ. + * This vector is incremented, not assigned. + * \return the reciprocal space energy. + */ + Real convolveEV(int parameterAngMom, const Matrix ¶meters, Matrix &virial) { + return convolveEVFxn_(aDim_, bDim_, cDim_, scaleFactor_, compGridXYZ_, recVecs_, cellVolume(), kappa_, + aSplineMod_, bSplineMod_, cSplineMod_, parameterAngMom, parameters, virial); + } + + /*! + * \brief Spread the parameters onto the charge grid. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * Generally this shouldn't be called; use runPME() instead. If you know what you're doing + * you can call this routine, which will yield the density in the realGrid_ member. + */ + void spreadParameters(int parameterAngMom, const Matrix ¶meters, const Matrix &coordinates) { + realGrid_.setZero(); + updateAngMomIterator(parameterAngMom); + int nComponents = nCartesian(parameterAngMom); + size_t nAtoms = coordinates.nRows(); + for (size_t atom = 0; atom < nAtoms; ++atom) { + auto bSplines = makeBSplines(coordinates[atom], parameterAngMom); + auto splineA = std::get<0>(bSplines); + auto splineB = std::get<1>(bSplines); + auto splineC = std::get<2>(bSplines); + const auto &aGridIterator = aGridIterator_[splineA.startingGridPoint()]; + const auto &bGridIterator = bGridIterator_[splineB.startingGridPoint()]; + const auto &cGridIterator = cGridIterator_[splineC.startingGridPoint()]; + for (int component = 0; component < nComponents; ++component) { + const auto &quanta = angMomIterator_[component]; + Real param = parameters(atom, component); + const Real *splineValsA = splineA[quanta[0]]; + const Real *splineValsB = splineB[quanta[1]]; + const Real *splineValsC = splineC[quanta[2]]; + for (const auto &cPoint : cGridIterator) { + Real cValP = param * splineValsC[cPoint.second]; + for (const auto &bPoint : bGridIterator) { + Real cbValP = cValP * splineValsB[bPoint.second]; + Real *cbRow = realGrid_[cPoint.first * bDim_ + bPoint.first]; + for (const auto &aPoint : aGridIterator) { + cbRow[aPoint.first] += cbValP * splineValsA[aPoint.second]; + } + } + } + } + } + } + + /*! + * \brief Probes the potential grid to get the forces. + * + * Generally this shouldn't be called; use runPME() instead. If you know what you're doing + * you can call this routine, which will yield the density in the realGrid_ member. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + */ + void probeGrid(int parameterAngMom, const Matrix ¶meters, const Matrix &coordinates, + Matrix &forces) { + updateAngMomIterator(parameterAngMom + 1); + int nComponents = nCartesian(parameterAngMom); + int nForceComponents = nCartesian(parameterAngMom + 1); + size_t nAtoms = coordinates.nRows(); + for (size_t atom = 0; atom < nAtoms; ++atom) { + Matrix fractionalPhis(1, nForceComponents); + fractionalPhis.setZero(); + + auto bSplines = makeBSplines(coordinates[atom], parameterAngMom + 1); + auto splineA = std::get<0>(bSplines); + auto splineB = std::get<1>(bSplines); + auto splineC = std::get<2>(bSplines); + const auto &aGridIterator = aGridIterator_[splineA.startingGridPoint()]; + const auto &bGridIterator = bGridIterator_[splineB.startingGridPoint()]; + const auto &cGridIterator = cGridIterator_[splineC.startingGridPoint()]; + for (const auto &cPoint : cGridIterator) { + for (const auto &bPoint : bGridIterator) { + Real *cbRow = realGrid_[cPoint.first * bDim_ + bPoint.first]; + for (const auto &aPoint : aGridIterator) { + Real gridVal = cbRow[aPoint.first]; + for (int component = 0; component < nForceComponents; ++component) { + const auto &quanta = angMomIterator_[component]; + const Real *splineValsA = splineA[quanta[0]]; + const Real *splineValsB = splineB[quanta[1]]; + const Real *splineValsC = splineC[quanta[2]]; + fractionalPhis[0][component] += gridVal * splineValsA[aPoint.second] * + splineValsB[bPoint.second] * splineValsC[cPoint.second]; + } + } + } + } + + Real fracForce[3] = {0, 0, 0}; + for (int component = 0; component < nComponents; ++component) { + Real param = parameters(atom, component); + const auto &quanta = angMomIterator_[component]; + short lx = quanta[0]; + short ly = quanta[1]; + short lz = quanta[2]; + fracForce[0] += param * fractionalPhis(0, cartAddress(lx + 1, ly, lz)); + fracForce[1] += param * fractionalPhis(0, cartAddress(lx, ly + 1, lz)); + fracForce[2] += param * fractionalPhis(0, cartAddress(lx, ly, lz + 1)); + } + forces(atom, 0) += scaledRecVecs_[0][0] * fracForce[0] + scaledRecVecs_[0][1] * fracForce[1] + + scaledRecVecs_[0][2] * fracForce[2]; + forces(atom, 1) += scaledRecVecs_[1][0] * fracForce[0] + scaledRecVecs_[1][1] * fracForce[1] + + scaledRecVecs_[1][2] * fracForce[2]; + forces(atom, 2) += scaledRecVecs_[2][0] * fracForce[0] + scaledRecVecs_[2][1] * fracForce[1] + + scaledRecVecs_[2][2] * fracForce[2]; + } + } + + /*! + * \brief computeESlf computes the Ewald self interaction energy. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \return the self energy. + */ + Real computeESlf(int parameterAngMom, const Matrix ¶meters) { + return slfEFxn_(parameterAngMom, parameters, kappa_, scaleFactor_); + } + + /*! + * \brief computeEDir computes the direct space energy. This is provided mostly for debugging and testing purposes; + * generally the host program should provide the pairwise interactions. + * \param pairList dense list of atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \return the direct space energy. + */ + Real computeEDir(const Matrix &pairList, int parameterAngMom, const Matrix ¶meters, + const Matrix &coordinates) { + if (parameterAngMom) throw std::runtime_error("Multipole self terms have not been coded yet."); + + Real energy = 0; + Real kappaSquared = kappa_ * kappa_; + size_t nPair = pairList.nRows(); + for (int pair = 0; pair < nPair; ++pair) { + short i = pairList(pair, 0); + short j = pairList(pair, 1); + auto deltaR = coordinates.row(j) - coordinates.row(i); + // TODO: apply minimum image convention. + Real rSquared = deltaR.dot(deltaR); + energy += parameters(i, 0) * parameters(j, 0) * dirEFxn_(rSquared, kappaSquared); + } + return scaleFactor_ * energy; + } + + /*! + * \brief computeEFDir computes the direct space energy and force. This is provided mostly for debugging and + * testing purposes; generally the host program should provide the pairwise interactions. + * \param pairList dense list of atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + * This matrix is incremented, not assigned. + * \return the direct space energy. + */ + Real computeEFDir(const Matrix &pairList, int parameterAngMom, const Matrix ¶meters, + const Matrix &coordinates, Matrix &forces) { + if (parameterAngMom) throw std::runtime_error("Multipole self terms have not been coded yet."); + + Real energy = 0; + Real kappaSquared = kappa_ * kappa_; + size_t nPair = pairList.nRows(); + for (int pair = 0; pair < nPair; ++pair) { + short i = pairList(pair, 0); + short j = pairList(pair, 1); + auto deltaR = coordinates.row(j) - coordinates.row(i); + // TODO: apply minimum image convention. + Real rSquared = deltaR.dot(deltaR); + auto kernels = dirEFFxn_(rSquared, kappa_, kappaSquared); + Real eKernel = std::get<0>(kernels); + Real fKernel = std::get<1>(kernels); + Real prefactor = scaleFactor_ * parameters(i, 0) * parameters(j, 0); + energy += prefactor * eKernel; + Real f = prefactor * fKernel; + auto force = deltaR.row(0); + force *= f; + forces.row(i) -= force; + forces.row(j) += force; + } + return energy; + } + + /*! + * \brief computeEFVDir computes the direct space energy, force and virial. This is provided mostly for debugging + * and testing purposes; generally the host program should provide the pairwise interactions. + * \param pairList dense list of atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + * This matrix is incremented, not assigned. + * \param virial a vector of length 6 containing the unique virial elements, in the order XX XY YY XZ YZ ZZ. + * This vector is incremented, not assigned. + * \return the direct space energy. + */ + Real computeEFVDir(const Matrix &pairList, int parameterAngMom, const Matrix ¶meters, + const Matrix &coordinates, Matrix &forces, Matrix &virial) { + if (parameterAngMom) throw std::runtime_error("Multipole self terms have not been coded yet."); + + Real energy = 0; + Real kappaSquared = kappa_ * kappa_; + size_t nPair = pairList.nRows(); + for (int pair = 0; pair < nPair; ++pair) { + short i = pairList(pair, 0); + short j = pairList(pair, 1); + auto deltaR = coordinates.row(j) - coordinates.row(i); + // TODO: apply minimum image convention. + Real rSquared = deltaR.dot(deltaR); + auto kernels = dirEFFxn_(rSquared, kappa_, kappaSquared); + Real eKernel = std::get<0>(kernels); + Real fKernel = std::get<1>(kernels); + Real prefactor = scaleFactor_ * parameters(i, 0) * parameters(j, 0); + energy += prefactor * eKernel; + Real f = prefactor * fKernel; + Matrix dRCopy = deltaR.clone(); + auto force = dRCopy.row(0); + force *= f; + forces.row(i) -= force; + forces.row(j) += force; + virial[0][0] -= force[0] * deltaR[0][0]; + virial[0][1] -= 0.5f * (force[0] * deltaR[0][1] + force[1] * deltaR[0][0]); + virial[0][2] -= force[1] * deltaR[0][1]; + virial[0][3] -= 0.5f * (force[0] * deltaR[0][2] + force[2] * deltaR[0][0]); + virial[0][4] -= 0.5f * (force[1] * deltaR[0][2] + force[2] * deltaR[0][1]); + virial[0][5] -= force[2] * deltaR[0][2]; + } + return energy; + } + + /*! + * \brief computeEAdj computes the adjusted real space energy which extracts the energy for excluded pairs that is + * present in reciprocal space. This is provided mostly for debugging and testing purposes; generally the + * host program should provide the pairwise interactions. + * \param pairList dense list of atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \return the adjusted energy. + */ + Real computeEAdj(const Matrix &pairList, int parameterAngMom, const Matrix ¶meters, + const Matrix &coordinates) { + if (parameterAngMom) throw std::runtime_error("Multipole self terms have not been coded yet."); + + Real energy = 0; + Real kappaSquared = kappa_ * kappa_; + size_t nPair = pairList.nRows(); + for (int pair = 0; pair < nPair; ++pair) { + short i = pairList(pair, 0); + short j = pairList(pair, 1); + auto deltaR = coordinates.row(j) - coordinates.row(i); + // TODO: apply minimum image convention. + Real rSquared = deltaR.dot(deltaR); + energy += parameters(i, 0) * parameters(j, 0) * adjEFxn_(rSquared, kappaSquared); + } + return scaleFactor_ * energy; + } + + /*! + * \brief computeEFAdj computes the adjusted energy and force. This is provided mostly for debugging and testing + * purposes; generally the host program should provide the pairwise interactions. + * \param pairList dense list of atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + * This matrix is incremented, not assigned. + * \return the adjusted energy. + */ + Real computeEFAdj(const Matrix &pairList, int parameterAngMom, const Matrix ¶meters, + const Matrix &coordinates, Matrix &forces) { + if (parameterAngMom) throw std::runtime_error("Multipole self terms have not been coded yet."); + + Real energy = 0; + Real kappaSquared = kappa_ * kappa_; + size_t nPair = pairList.nRows(); + for (int pair = 0; pair < nPair; ++pair) { + short i = pairList(pair, 0); + short j = pairList(pair, 1); + auto deltaR = coordinates.row(j) - coordinates.row(i); + // TODO: apply minimum image convention. + Real rSquared = deltaR.dot(deltaR); + auto kernels = adjEFFxn_(rSquared, kappa_, kappaSquared); + Real eKernel = std::get<0>(kernels); + Real fKernel = std::get<1>(kernels); + Real prefactor = scaleFactor_ * parameters(i, 0) * parameters(j, 0); + energy += prefactor * eKernel; + Real f = prefactor * fKernel; + auto force = deltaR.row(0); + force *= f; + forces.row(i) -= force; + forces.row(j) += force; + } + return energy; + } + + /*! + * \brief computeEFVAdj computes the adjusted energy, forces and virial. This is provided mostly for debugging + * and testing purposes; generally the host program should provide the pairwise interactions. + * \param pairList dense list of atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + * This matrix is incremented, not assigned. + * \param virial a vector of length 6 containing the unique virial elements, in the order XX XY YY XZ YZ ZZ. + * This vector is incremented, not assigned. + * \return the adjusted energy. + */ + Real computeEFVAdj(const Matrix &pairList, int parameterAngMom, const Matrix ¶meters, + const Matrix &coordinates, Matrix &forces, Matrix &virial) { + if (parameterAngMom) throw std::runtime_error("Multipole self terms have not been coded yet."); + + Real energy = 0; + Real kappaSquared = kappa_ * kappa_; + size_t nPair = pairList.nRows(); + for (int pair = 0; pair < nPair; ++pair) { + short i = pairList(pair, 0); + short j = pairList(pair, 1); + auto deltaR = coordinates.row(j) - coordinates.row(i); + // TODO: apply minimum image convention. + Real rSquared = deltaR.dot(deltaR); + auto kernels = adjEFFxn_(rSquared, kappa_, kappaSquared); + Real eKernel = std::get<0>(kernels); + Real fKernel = std::get<1>(kernels); + Real prefactor = scaleFactor_ * parameters(i, 0) * parameters(j, 0); + energy += prefactor * eKernel; + Real f = prefactor * fKernel; + Matrix dRCopy = deltaR.clone(); + auto force = dRCopy.row(0); + force *= f; + forces.row(i) -= force; + forces.row(j) += force; + virial[0][0] -= force[0] * deltaR[0][0]; + virial[0][1] -= 0.5f * (force[0] * deltaR[0][1] + force[1] * deltaR[0][0]); + virial[0][2] -= force[1] * deltaR[0][1]; + virial[0][3] -= 0.5f * (force[0] * deltaR[0][2] + force[2] * deltaR[0][0]); + virial[0][4] -= 0.5f * (force[1] * deltaR[0][2] + force[2] * deltaR[0][1]); + virial[0][5] -= force[2] * deltaR[0][2]; + } + return energy; + } + + /*! + * \brief Runs a PME reciprocal space calculation, computing energies. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param energy pointer to the variable holding the energy; this is incremented, not assigned. + * \return the reciprocal space energy. + */ + Real computeERec(int parameterAngMom, const Matrix ¶meters, const Matrix &coordinates) { + sanityChecks(parameterAngMom, parameters, coordinates); + + spreadParameters(parameterAngMom, parameters, coordinates); + forwardTransform(); + return convolveE(parameterAngMom, parameters); + } + + /*! + * \brief Runs a PME reciprocal space calculation, computing energies and forces. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param energy pointer to the variable holding the energy; this is incremented, not assigned. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + * This matrix is incremented, not assigned. + * \return the reciprocal space energy. + */ + Real computeEFRec(int parameterAngMom, const Matrix ¶meters, const Matrix &coordinates, + Matrix &forces) { + sanityChecks(parameterAngMom, parameters, coordinates); + + spreadParameters(parameterAngMom, parameters, coordinates); + forwardTransform(); + Real energy = convolveE(parameterAngMom, parameters); + inverseTransform(); + probeGrid(parameterAngMom, parameters, coordinates, forces); + + return energy; + } + + /*! + * \brief Runs a PME reciprocal space calculation, computing energies, forces and the virial. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param energy pointer to the variable holding the energy; this is incremented, not assigned. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + * This matrix is incremented, not assigned. + * \param virial a vector of length 6 containing the unique virial elements, in the order XX XY YY XZ YZ ZZ. + * This vector is incremented, not assigned. + * \return the reciprocal space energy. + */ + Real computeEFVRec(int parameterAngMom, const Matrix ¶meters, const Matrix &coordinates, + Matrix &forces, Matrix &virial) { + sanityChecks(parameterAngMom, parameters, coordinates); + + spreadParameters(parameterAngMom, parameters, coordinates); + forwardTransform(); + Real energy = convolveEV(parameterAngMom, parameters, virial); + inverseTransform(); + probeGrid(parameterAngMom, parameters, coordinates, forces); + + return energy; + } + + /*! + * \brief Runs a full (direct and reciprocal space) PME calculation, computing the energy. The direct space + * implementation here is not totally optimal, so this routine should primarily be used for testing and + * debugging. + * \param includedList dense list of included atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN,jN. + * \param excludedList dense list of excluded atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param energy pointer to the variable holding the energy; this is incremented, not assigned. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + * This matrix is incremented, not assigned. + * \return the full PME energy. + */ + Real computeEAll(const Matrix &includedList, const Matrix &excludedList, int parameterAngMom, + const Matrix ¶meters, const Matrix &coordinates) { + Real energy = computeERec(parameterAngMom, parameters, coordinates); + energy += computeESlf(parameterAngMom, parameters); + energy += computeEDir(includedList, parameterAngMom, parameters, coordinates); + energy += computeEAdj(excludedList, parameterAngMom, parameters, coordinates); + return energy; + } + + /*! + * \brief Runs a full (direct and reciprocal space) PME calculation, computing energies and forces. The direct + * space implementation here is not totally optimal, so this routine should primarily be used for testing + * and debugging. + * \param includedList dense list of included atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param excludedList dense list of excluded atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param energy pointer to the variable holding the energy; this is incremented, not assigned. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + * This matrix is incremented, not assigned. + * \return the full PME energy. + */ + Real computeEFAll(const Matrix &includedList, const Matrix &excludedList, int parameterAngMom, + const Matrix ¶meters, const Matrix &coordinates, Matrix &forces) { + Real energy = computeEFRec(parameterAngMom, parameters, coordinates, forces); + energy += computeESlf(parameterAngMom, parameters); + energy += computeEFDir(includedList, parameterAngMom, parameters, coordinates, forces); + energy += computeEFAdj(excludedList, parameterAngMom, parameters, coordinates, forces); + return energy; + } + + /*! + * \brief Runs a full (direct and reciprocal space) PME calculation, computing energies, forces and virials. + * The direct space implementation here is not totally optimal, so this routine should primarily + * be used for testing and debugging. + * \param includedList dense list of included atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param excludedList dense list of excluded atom pairs, ordered like i1, j1, i2, j2, i3, j3, ... iN, jN. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param energy pointer to the variable holding the energy; this is incremented, not assigned. + * \param forces a Nx3 matrix of the forces, ordered in memory as {Fx1,Fy1,Fz1,Fx2,Fy2,Fz2,....FxN,FyN,FzN}. + * This matrix is incremented, not assigned. + * \param virial a vector of length 6 containing the unique virial elements, in the order XX XY YY XZ YZ ZZ. + * This vector is incremented, not assigned. + * \return the full PME energy. + */ + Real computeEFVAll(const Matrix &includedList, const Matrix &excludedList, int parameterAngMom, + const Matrix ¶meters, const Matrix &coordinates, Matrix &forces, + Matrix &virial) { + Real energy = computeEFVRec(parameterAngMom, parameters, coordinates, forces, virial); + energy += computeESlf(parameterAngMom, parameters); + energy += computeEFVDir(includedList, parameterAngMom, parameters, coordinates, forces, virial); + energy += computeEFVAdj(excludedList, parameterAngMom, parameters, coordinates, forces, virial); + return energy; + } + + /*! + * \brief makeGridIterator makes an iterator over the spline values that contribute to this node's grid + * in a given Cartesian dimension. The iterator is of the form (grid point, spline index) and is + * sorted by increasing grid point, for cache efficiency. + * \param dimension the dimension of the grid in the Cartesian dimension of interest. + * \param first the first grid point in the Cartesian dimension to be handled by this node. + * \param last the element past the last grid point in the Cartesian dimension to be handled by this node. + * \return the vector of spline iterators for each starting grid point. + */ + GridIterator makeGridIterator(int dimension, int first, int last) { + // TODO make me private! + GridIterator gridIterator; + for (int gridStart = 0; gridStart < dimension; ++gridStart) { + std::vector> splineIterator(splineOrder_); + splineIterator.clear(); + for (int splineIndex = 0; splineIndex < splineOrder_; ++splineIndex) { + int gridPoint = (splineIndex + gridStart) % dimension; + if (gridPoint >= first && gridPoint < last) + splineIterator.push_back(std::make_pair(gridPoint - first, splineIndex)); + } + std::sort(splineIterator.begin(), splineIterator.end()); + gridIterator.push_back(splineIterator); + } + return gridIterator; + } + + /*! + * \brief common_init sets up information that is common to serial and parallel runs. + */ + void common_init(int rPower, Real kappa, int splineOrder, int aDim, int bDim, int cDim, Real scaleFactor, + int nThreads) { + // TODO make this private! + aDim_ = aDim; + bDim_ = bDim; + cDim_ = cDim; + xDim_ = aDim / 2 + 1; + splineOrder_ = splineOrder; + nThreads_ = nThreads; + scaleFactor_ = scaleFactor; + kappa_ = kappa; + + // Helpers to perform 1D FFTs along each dimension. + fftHelperA_ = FFTWWrapper(aDim_); + fftHelperB_ = FFTWWrapper(bDim_); + fftHelperC_ = FFTWWrapper(cDim_); + + // Grid iterators to correctly wrap the grid when using splines. + aGridIterator_ = makeGridIterator(aDim_, firstX_, lastX_); + bGridIterator_ = makeGridIterator(bDim_, firstY_, lastY_); + cGridIterator_ = makeGridIterator(cDim_, firstZ_, lastZ_); + + // Fourier space spline norms. + BSpline spline = BSpline(0, 0, splineOrder_, 0); + aSplineMod_ = spline.invSplineModuli(aDim_); + bSplineMod_ = spline.invSplineModuli(bDim_); + cSplineMod_ = spline.invSplineModuli(cDim_); + + // Set up function pointers by instantiating the appropriate evaluation functions. We could add many more + // entries by default here, but don't right now to avoid code bloat. To add an extra rPower kernel is a + // trivial cut and paste exercise; just add a new line with the desired 1/R power as the macro's argument. + switch (rPower) { + ENABLE_KERNEL_WITH_INVERSE_R_EXPONENT_OF(1); + ENABLE_KERNEL_WITH_INVERSE_R_EXPONENT_OF(6); + default: + std::string msg("Bad rPower requested. To fix this, add the appropriate entry in"); + msg += __FILE__; + msg += ", line number "; + msg += std::to_string(__LINE__ - 5); + throw std::runtime_error(msg.c_str()); + break; + } + + // The matrices used in the transformations. + realGrid_ = Matrix(myDimZ_ * myDimY_, myDimX_); + compGridCXB_ = Matrix>(cDim_ * xDim_, bDim_); + compGridCBX_ = Matrix>(cDim_ * bDim_, xDim_); + compGridXYC_ = Matrix>(xDim_ * bDim_, cDim_); + compGridXYZ_ = Matrix>(xDim_ * bDim_, cDim_); + } + + /*! + * \brief setup initializes this object for a PME calculation using only threading. + * \param rPower the exponent of the (inverse) distance kernel (e.g. 1 for Coulomb, 6 for attractive dispersion). + * \param kappa the attenuation parameter in units inverse of those used to specify coordinates. + * \param splineOrder the order of B-spline; must be at least (2 + max. multipole order + deriv. level needed). + * \param aDim the dimension of the FFT grid along the A axis. + * \param bDim the dimension of the FFT grid along the B axis. + * \param cDim the dimension of the FFT grid along the C axis. + * \param scaleFactor a scale factor to be applied to all computed energies and derivatives thereof (e.g. the + * 1 / [4 pi epslion0] for Coulomb calculations). + * \param nThreads the maximum number of threads to use for each MPI instance; if set to 0 all available threads are + * used. + */ + void setup(int rPower, Real kappa, int splineOrder, int aDim, int bDim, int cDim, Real scaleFactor, int nThreads) { + rankX_ = rankY_ = rankZ_ = 0; + firstX_ = firstY_ = firstZ_ = 0; + lastX_ = aDim; + lastY_ = bDim; + lastZ_ = cDim; + myDimX_ = aDim; + myDimY_ = bDim; + myDimZ_ = cDim; + common_init(rPower, kappa, splineOrder, aDim, bDim, cDim, scaleFactor, nThreads); + } + + /*! + * \brief Runs a PME reciprocal space calculation, computing energies in an MPI parallel fashion. + * \param parameterAngMom the angular momentum of the parameters (0 for charges, C6 coefficients, 2 for quadrupoles, + * etc.). + * \param parameters the list of parameters associated with each atom (charges, C6 coefficients, multipoles, + * etc...). For a parameter with angular momentum L, a matrix of dimension nAtoms x nL is expected, where nL = + * (L+1)*(L+2)*(L+3)/6 and the fast running index nL has the ordering + * + * 0 X Y Z XX XY YY XZ YZ ZZ XXX XXY XYY YYY XXZ XYZ YYZ XZZ YZZ ZZZ ... + * + * i.e. generated by the python loops + * \code{.py} + * for L in range(maxAM+1): + * for Lz in range(0,L+1): + * for Ly in range(0, L - Lz + 1): + * Lx = L - Ly - Lz + * \endcode + * \param coordinates the cartesian coordinates, ordered in memory as {x1,y1,z1,x2,y2,z2,....xN,yN,zN}. + * \param energy pointer to the variable holding the energy; this is incremented, not assigned. + * \return the reciprocal space energy. + */ + Real computeERecParallel(int parameterAngMom, const Matrix ¶meters, const Matrix &coordinates) { + sanityChecks(parameterAngMom, parameters, coordinates); + + spreadParameters(parameterAngMom, parameters, coordinates); + PRINT(realGrid_); + return 0; + forwardTransform(); + return convolveE(parameterAngMom, parameters); + } +}; +} // Namespace libpme + +using PMEInstanceD = libpme::PMEInstance; +using PMEInstanceF = libpme::PMEInstance; + +#else + +// C header +#include + +typedef enum { XAligned = 0, ShapeMatrix = 1 } LatticeType; + +typedef struct PMEInstance PMEInstance; +extern struct PMEInstance *libpme_createD(); +extern struct PMEInstance *libpme_createF(); +extern void libpme_setupD(struct PMEInstance *pme, int rPower, double kappa, int splineOrder, int aDim, int bDim, + int cDim, double scaleFactor, int nThreads); +extern void libpme_setupF(struct PMEInstance *pme, int rPower, float kappa, int splineOrder, int aDim, int bDim, + int cDim, float scaleFactor, int nThreads); +extern void libpme_set_lattice_vectorsD(struct PMEInstance *pme, double A, double B, double C, double kappa, + double beta, double gamma, LatticeType latticeType); +extern void libpme_set_lattice_vectorsF(struct PMEInstance *pme, float A, float B, float C, float kappa, float beta, + float gamma, LatticeType latticeType); +extern double libpme_compute_EF_recD(struct PMEInstance *pme, size_t nAtoms, int parameterAngMom, double *parameters, + double *coordinates, double *forces); +extern float libpme_compute_EF_recF(struct PMEInstance *pme, size_t nAtoms, int parameterAngMom, float *parameters, + float *coordinates, float *forces); +#endif // C++/C +#endif // Header guard diff --git a/src/readline/Makefile b/src/readline/Makefile index 4b91cfe6dd..6b5d283ec1 100644 --- a/src/readline/Makefile +++ b/src/readline/Makefile @@ -1,2 +1,619 @@ include ../../config.h -include Makefile_main +############################################################################# +# Makefile for building: libreadline.a +# Generated by qmake (2.01a) (Qt 4.2.3) on: Fri May 4 12:47:53 2007 +# Project: readline.pro +# Template: lib +# Command: /usr/bin/qmake -unix -o Makefile readline.pro +############################################################################# + +####### Compiler, tools and options + +DEFINES = -DHAVE_CONFIG_H +CFLAGS += $(DEFINES) +CXXFLAGS += $(DEFINES) +LEXFLAGS = +YACCFLAGS = -d +INCPATH = -I. +AR = ar cqs +RANLIB = +QMAKE = /usr/bin/qmake +TAR = tar -cf +COMPRESS = gzip -9f +COPY = cp -f +COPY_FILE = $(COPY) +COPY_DIR = $(COPY) -r +INSTALL_FILE = install -m 644 -p +INSTALL_DIR = $(COPY_DIR) +INSTALL_PROGRAM = install -m 755 -p +DEL_FILE = rm -f +SYMLINK = ln -sf +DEL_DIR = rmdir +MOVE = mv -f +CHK_DIR_EXISTS= test -d +MKDIR = mkdir -p + +####### Output directory + +OBJECTS_DIR = ./ + +####### Files + +SOURCES = bind.c \ + callback.c \ + compat.c \ + complete.c \ + display.c \ + funmap.c \ + histexpand.c \ + histfile.c \ + history.c \ + histsearch.c \ + input.c \ + isearch.c \ + keymaps.c \ + kill.c \ + macro.c \ + mbutil.c \ + misc.c \ + nls.c \ + parens.c \ + readline.c \ + rltty.c \ + savestring.c \ + search.c \ + shell.c \ + signals.c \ + termcap.c \ + terminal.c \ + text.c \ + tilde.c \ + tparam.c \ + undo.c \ + util.c \ + version.c \ + vi_mode.c \ + xmalloc.c +OBJECTS = bind.o \ + callback.o \ + compat.o \ + complete.o \ + display.o \ + funmap.o \ + histexpand.o \ + histfile.o \ + history.o \ + histsearch.o \ + input.o \ + isearch.o \ + keymaps.o \ + kill.o \ + macro.o \ + mbutil.o \ + misc.o \ + nls.o \ + parens.o \ + readline.o \ + rltty.o \ + savestring.o \ + search.o \ + shell.o \ + signals.o \ + termcap.o \ + terminal.o \ + text.o \ + tilde.o \ + tparam.o \ + undo.o \ + util.o \ + version.o \ + vi_mode.o \ + xmalloc.o +QMAKE_TARGET = readline +DESTDIR = +TARGET = libreadline.a + +first: all +####### Implicit rules + +.SUFFIXES: .o .c .cpp .cc .cxx .C + +.cpp.o: + $(CXX) -c $(CXXFLAGS) $(INCPATH) -o "$@" "$<" + +.cc.o: + $(CXX) -c $(CXXFLAGS) $(INCPATH) -o "$@" "$<" + +.cxx.o: + $(CXX) -c $(CXXFLAGS) $(INCPATH) -o "$@" "$<" + +.C.o: + $(CXX) -c $(CXXFLAGS) $(INCPATH) -o "$@" "$<" + +.c.o: + $(CC) -c $(CFLAGS) $(INCPATH) -o "$@" "$<" + +####### Build rules + +all: $(TARGET) + +staticlib: $(TARGET) + +$(TARGET): $(OBJECTS) $(OBJCOMP) + -$(DEL_FILE) $(TARGET) + $(AR) $(TARGET) $(OBJECTS) + + +####### Compile + +bind.o: bind.c config.h \ + ansi_stdlib.h \ + posixstat.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + rlshell.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o bind.o bind.c + +callback.o: callback.c config.h \ + rlconf.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + rlprivate.h \ + posixjmp.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o callback.o callback.c + +compat.o: compat.c config.h \ + rlstdc.h \ + rltypedefs.h + $(CC) -c $(CFLAGS) $(INCPATH) -o compat.o compat.c + +complete.o: complete.c config.h \ + ansi_stdlib.h \ + posixdir.h \ + posixstat.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + xmalloc.h \ + rlprivate.h \ + posixjmp.h + $(CC) -c $(CFLAGS) $(INCPATH) -o complete.o complete.c + +display.o: display.c config.h \ + posixstat.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + tcap.h \ + rltty.h \ + rlwinsize.h \ + termcap.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o display.o display.c + +funmap.o: funmap.c config.h \ + ansi_stdlib.h \ + rlconf.h \ + readline.h \ + rlstdc.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o funmap.o funmap.c + +histexpand.o: histexpand.c config.h \ + ansi_stdlib.h \ + rlmbutil.h \ + rlstdc.h \ + history.h \ + rltypedefs.h \ + histlib.h \ + rlshell.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o histexpand.o histexpand.c + +histfile.o: histfile.c config.h \ + posixstat.h \ + ansi_stdlib.h \ + history.h \ + rlstdc.h \ + rltypedefs.h \ + histlib.h \ + rlshell.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o histfile.o histfile.c + +history.o: history.c config.h \ + ansi_stdlib.h \ + history.h \ + rlstdc.h \ + rltypedefs.h \ + histlib.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o history.o history.c + +histsearch.o: histsearch.c config.h \ + ansi_stdlib.h \ + history.h \ + rlstdc.h \ + rltypedefs.h \ + histlib.h + $(CC) -c $(CFLAGS) $(INCPATH) -o histsearch.o histsearch.c + +input.o: input.c config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + rlprivate.h \ + posixjmp.h \ + rlshell.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o input.o input.c + +isearch.o: isearch.c config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o isearch.o isearch.c + +keymaps.o: keymaps.c config.h \ + ansi_stdlib.h \ + readline.h \ + rlstdc.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + rlconf.h \ + emacs_keymap.c \ + vi_keymap.c \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o keymaps.o keymaps.c + +kill.o: kill.c config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o kill.o kill.c + +macro.o: macro.c config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o macro.o macro.c + +mbutil.o: mbutil.c config.h \ + posixjmp.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + rlprivate.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o mbutil.o mbutil.c + +misc.o: misc.c config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + rlshell.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o misc.o misc.c + +nls.o: nls.c config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + rlshell.h \ + rlprivate.h \ + posixjmp.h + $(CC) -c $(CFLAGS) $(INCPATH) -o nls.o nls.c + +parens.o: parens.c rlconf.h \ + config.h \ + readline.h \ + rlstdc.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + rlprivate.h \ + posixjmp.h + $(CC) -c $(CFLAGS) $(INCPATH) -o parens.o parens.c + +readline.o: readline.c config.h \ + posixstat.h \ + ansi_stdlib.h \ + posixjmp.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + rlshell.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o readline.o readline.c + +rltty.o: rltty.c config.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rltty.h \ + rlwinsize.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + rlprivate.h \ + posixjmp.h + $(CC) -c $(CFLAGS) $(INCPATH) -o rltty.o rltty.c + +savestring.o: savestring.c config.h \ + xmalloc.h \ + rlstdc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o savestring.o savestring.c + +search.o: search.c config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o search.o search.c + +shell.o: shell.c config.h \ + ansi_stdlib.h \ + rlstdc.h \ + rlshell.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o shell.o shell.c + +signals.o: signals.c config.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h + $(CC) -c $(CFLAGS) $(INCPATH) -o signals.o signals.c + +termcap.o: termcap.c config.h + $(CC) -c $(CFLAGS) $(INCPATH) -o termcap.o termcap.c + +terminal.o: terminal.c config.h \ + posixstat.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rltty.h \ + rlwinsize.h \ + tcap.h \ + termcap.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + rlshell.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o terminal.o terminal.c + +text.o: text.c config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + rlshell.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o text.o text.c + +tilde.o: tilde.c config.h \ + ansi_stdlib.h \ + tilde.h \ + xmalloc.h \ + rlstdc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o tilde.o tilde.c + +tparam.o: tparam.c config.h + $(CC) -c $(CFLAGS) $(INCPATH) -o tparam.o tparam.c + +undo.o: undo.c config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o undo.o undo.c + +util.o: util.c config.h \ + posixjmp.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlconf.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + rlprivate.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o util.o util.c + +version.o: version.c + $(CC) -c $(CFLAGS) $(INCPATH) -o version.o version.c + +vi_mode.o: vi_mode.c rlconf.h \ + config.h \ + ansi_stdlib.h \ + rldefs.h \ + rlstdc.h \ + rlmbutil.h \ + readline.h \ + rltypedefs.h \ + keymaps.h \ + chardefs.h \ + tilde.h \ + history.h \ + rlprivate.h \ + posixjmp.h \ + xmalloc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o vi_mode.o vi_mode.c + +xmalloc.o: xmalloc.c config.h \ + ansi_stdlib.h \ + xmalloc.h \ + rlstdc.h + $(CC) -c $(CFLAGS) $(INCPATH) -o xmalloc.o xmalloc.c + +####### Install + +install: FORCE + +uninstall: clean + +FORCE: + +####### Clean + +clean: + /bin/rm -f *.o $(TARGET) + diff --git a/src/readline/Makefile_at b/src/readline/Makefile_at deleted file mode 100644 index 319f6b3e18..0000000000 --- a/src/readline/Makefile_at +++ /dev/null @@ -1,2 +0,0 @@ -include ../../../config.h -include Makefile_main diff --git a/src/readline/Makefile_main b/src/readline/Makefile_main deleted file mode 100644 index 6fc0d22bfa..0000000000 --- a/src/readline/Makefile_main +++ /dev/null @@ -1,618 +0,0 @@ -############################################################################# -# Makefile for building: libreadline.a -# Generated by qmake (2.01a) (Qt 4.2.3) on: Fri May 4 12:47:53 2007 -# Project: readline.pro -# Template: lib -# Command: /usr/bin/qmake -unix -o Makefile readline.pro -############################################################################# - -####### Compiler, tools and options - -DEFINES = -DHAVE_CONFIG_H -CFLAGS += $(DEFINES) -CXXFLAGS += $(DEFINES) -LEXFLAGS = -YACCFLAGS = -d -INCPATH = -I. -AR = ar cqs -RANLIB = -QMAKE = /usr/bin/qmake -TAR = tar -cf -COMPRESS = gzip -9f -COPY = cp -f -COPY_FILE = $(COPY) -COPY_DIR = $(COPY) -r -INSTALL_FILE = install -m 644 -p -INSTALL_DIR = $(COPY_DIR) -INSTALL_PROGRAM = install -m 755 -p -DEL_FILE = rm -f -SYMLINK = ln -sf -DEL_DIR = rmdir -MOVE = mv -f -CHK_DIR_EXISTS= test -d -MKDIR = mkdir -p - -####### Output directory - -OBJECTS_DIR = ./ - -####### Files - -SOURCES = bind.c \ - callback.c \ - compat.c \ - complete.c \ - display.c \ - funmap.c \ - histexpand.c \ - histfile.c \ - history.c \ - histsearch.c \ - input.c \ - isearch.c \ - keymaps.c \ - kill.c \ - macro.c \ - mbutil.c \ - misc.c \ - nls.c \ - parens.c \ - readline.c \ - rltty.c \ - savestring.c \ - search.c \ - shell.c \ - signals.c \ - termcap.c \ - terminal.c \ - text.c \ - tilde.c \ - tparam.c \ - undo.c \ - util.c \ - version.c \ - vi_mode.c \ - xmalloc.c -OBJECTS = bind.o \ - callback.o \ - compat.o \ - complete.o \ - display.o \ - funmap.o \ - histexpand.o \ - histfile.o \ - history.o \ - histsearch.o \ - input.o \ - isearch.o \ - keymaps.o \ - kill.o \ - macro.o \ - mbutil.o \ - misc.o \ - nls.o \ - parens.o \ - readline.o \ - rltty.o \ - savestring.o \ - search.o \ - shell.o \ - signals.o \ - termcap.o \ - terminal.o \ - text.o \ - tilde.o \ - tparam.o \ - undo.o \ - util.o \ - version.o \ - vi_mode.o \ - xmalloc.o -QMAKE_TARGET = readline -DESTDIR = -TARGET = libreadline.a - -first: all -####### Implicit rules - -.SUFFIXES: .o .c .cpp .cc .cxx .C - -.cpp.o: - $(CXX) -c $(CXXFLAGS) $(INCPATH) -o "$@" "$<" - -.cc.o: - $(CXX) -c $(CXXFLAGS) $(INCPATH) -o "$@" "$<" - -.cxx.o: - $(CXX) -c $(CXXFLAGS) $(INCPATH) -o "$@" "$<" - -.C.o: - $(CXX) -c $(CXXFLAGS) $(INCPATH) -o "$@" "$<" - -.c.o: - $(CC) -c $(CFLAGS) $(INCPATH) -o "$@" "$<" - -####### Build rules - -all: Makefile_main $(TARGET) - -staticlib: $(TARGET) - -$(TARGET): $(OBJECTS) $(OBJCOMP) - -$(DEL_FILE) $(TARGET) - $(AR) $(TARGET) $(OBJECTS) - - -####### Compile - -bind.o: bind.c config.h \ - ansi_stdlib.h \ - posixstat.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - rlshell.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o bind.o bind.c - -callback.o: callback.c config.h \ - rlconf.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - rlprivate.h \ - posixjmp.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o callback.o callback.c - -compat.o: compat.c config.h \ - rlstdc.h \ - rltypedefs.h - $(CC) -c $(CFLAGS) $(INCPATH) -o compat.o compat.c - -complete.o: complete.c config.h \ - ansi_stdlib.h \ - posixdir.h \ - posixstat.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - xmalloc.h \ - rlprivate.h \ - posixjmp.h - $(CC) -c $(CFLAGS) $(INCPATH) -o complete.o complete.c - -display.o: display.c config.h \ - posixstat.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - tcap.h \ - rltty.h \ - rlwinsize.h \ - termcap.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o display.o display.c - -funmap.o: funmap.c config.h \ - ansi_stdlib.h \ - rlconf.h \ - readline.h \ - rlstdc.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o funmap.o funmap.c - -histexpand.o: histexpand.c config.h \ - ansi_stdlib.h \ - rlmbutil.h \ - rlstdc.h \ - history.h \ - rltypedefs.h \ - histlib.h \ - rlshell.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o histexpand.o histexpand.c - -histfile.o: histfile.c config.h \ - posixstat.h \ - ansi_stdlib.h \ - history.h \ - rlstdc.h \ - rltypedefs.h \ - histlib.h \ - rlshell.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o histfile.o histfile.c - -history.o: history.c config.h \ - ansi_stdlib.h \ - history.h \ - rlstdc.h \ - rltypedefs.h \ - histlib.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o history.o history.c - -histsearch.o: histsearch.c config.h \ - ansi_stdlib.h \ - history.h \ - rlstdc.h \ - rltypedefs.h \ - histlib.h - $(CC) -c $(CFLAGS) $(INCPATH) -o histsearch.o histsearch.c - -input.o: input.c config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - rlprivate.h \ - posixjmp.h \ - rlshell.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o input.o input.c - -isearch.o: isearch.c config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o isearch.o isearch.c - -keymaps.o: keymaps.c config.h \ - ansi_stdlib.h \ - readline.h \ - rlstdc.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - rlconf.h \ - emacs_keymap.c \ - vi_keymap.c \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o keymaps.o keymaps.c - -kill.o: kill.c config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o kill.o kill.c - -macro.o: macro.c config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o macro.o macro.c - -mbutil.o: mbutil.c config.h \ - posixjmp.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - rlprivate.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o mbutil.o mbutil.c - -misc.o: misc.c config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - rlshell.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o misc.o misc.c - -nls.o: nls.c config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - rlshell.h \ - rlprivate.h \ - posixjmp.h - $(CC) -c $(CFLAGS) $(INCPATH) -o nls.o nls.c - -parens.o: parens.c rlconf.h \ - config.h \ - readline.h \ - rlstdc.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - rlprivate.h \ - posixjmp.h - $(CC) -c $(CFLAGS) $(INCPATH) -o parens.o parens.c - -readline.o: readline.c config.h \ - posixstat.h \ - ansi_stdlib.h \ - posixjmp.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - rlshell.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o readline.o readline.c - -rltty.o: rltty.c config.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rltty.h \ - rlwinsize.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - rlprivate.h \ - posixjmp.h - $(CC) -c $(CFLAGS) $(INCPATH) -o rltty.o rltty.c - -savestring.o: savestring.c config.h \ - xmalloc.h \ - rlstdc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o savestring.o savestring.c - -search.o: search.c config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o search.o search.c - -shell.o: shell.c config.h \ - ansi_stdlib.h \ - rlstdc.h \ - rlshell.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o shell.o shell.c - -signals.o: signals.c config.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h - $(CC) -c $(CFLAGS) $(INCPATH) -o signals.o signals.c - -termcap.o: termcap.c config.h - $(CC) -c $(CFLAGS) $(INCPATH) -o termcap.o termcap.c - -terminal.o: terminal.c config.h \ - posixstat.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rltty.h \ - rlwinsize.h \ - tcap.h \ - termcap.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - rlshell.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o terminal.o terminal.c - -text.o: text.c config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - rlshell.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o text.o text.c - -tilde.o: tilde.c config.h \ - ansi_stdlib.h \ - tilde.h \ - xmalloc.h \ - rlstdc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o tilde.o tilde.c - -tparam.o: tparam.c config.h - $(CC) -c $(CFLAGS) $(INCPATH) -o tparam.o tparam.c - -undo.o: undo.c config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o undo.o undo.c - -util.o: util.c config.h \ - posixjmp.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlconf.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - rlprivate.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o util.o util.c - -version.o: version.c - $(CC) -c $(CFLAGS) $(INCPATH) -o version.o version.c - -vi_mode.o: vi_mode.c rlconf.h \ - config.h \ - ansi_stdlib.h \ - rldefs.h \ - rlstdc.h \ - rlmbutil.h \ - readline.h \ - rltypedefs.h \ - keymaps.h \ - chardefs.h \ - tilde.h \ - history.h \ - rlprivate.h \ - posixjmp.h \ - xmalloc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o vi_mode.o vi_mode.c - -xmalloc.o: xmalloc.c config.h \ - ansi_stdlib.h \ - xmalloc.h \ - rlstdc.h - $(CC) -c $(CFLAGS) $(INCPATH) -o xmalloc.o xmalloc.c - -####### Install - -install: FORCE - -uninstall: clean - -FORCE: - -####### Clean - -clean: - /bin/rm -f *.o $(TARGET) - diff --git a/src/xdrfile/Makefile b/src/xdrfile/Makefile index 4b91cfe6dd..860b99f7fb 100644 --- a/src/xdrfile/Makefile +++ b/src/xdrfile/Makefile @@ -1,2 +1,47 @@ include ../../config.h -include Makefile_main +# Variables + +AR = ar cqs +DEL_FILE = /bin/rm -f +TARGET = libxdrfile.a + +# General rules + +# Source files + +XDR_SOURCES=xdrfile.c xdr_seek.c xdrfile_trr.c xdrfile_xtc.c + +# Objects + +OBJECTS=$(XDR_SOURCES:.c=.o) + +# Specific rules + +all: $(TARGET) + +$(TARGET): $(OBJECTS) + -$(DEL_FILE) $(TARGET) + $(AR) $(TARGET) $(OBJECTS) + +.c.o: + $(CC) $(CFLAGS) -c -o $@ $< + +test: $(TARGET) xdrfile_c_test.o + $(CC) -o a.out xdrfile_c_test.c $(TARGET) -lm + ./a.out + +clean: + /bin/rm -f *.o $(TARGET) a.out test.trr test.xtc test.xdr + +uninstall: clean + +# Dependencies +xdrfile.o: xdrfile.c xdrfile.h + +xdrfile_trr.o: xdrfile_trr.c xdrfile_trr.h xdrfile.h + +xdrfile_xtc.o: xdrfile_xtc.c xdrfile_xtc.h xdrfile.h + +xdr_seek.o: xdr_seek.c xdr_seek.h xdrfile.h + +xdrfile_c_test.o: xdrfile_c_test.c xdrfile_xtc.h xdrfile_trr.h xdrfile.h diff --git a/src/xdrfile/Makefile_at b/src/xdrfile/Makefile_at deleted file mode 100644 index 319f6b3e18..0000000000 --- a/src/xdrfile/Makefile_at +++ /dev/null @@ -1,2 +0,0 @@ -include ../../../config.h -include Makefile_main diff --git a/src/xdrfile/Makefile_main b/src/xdrfile/Makefile_main deleted file mode 100644 index bce821ae60..0000000000 --- a/src/xdrfile/Makefile_main +++ /dev/null @@ -1,43 +0,0 @@ -# Variables - -AR = ar cqs -DEL_FILE = /bin/rm -f -TARGET = libxdrfile.a - -# General rules - -# Source files - -XDR_SOURCES=xdrfile.c xdr_seek.c xdrfile_trr.c xdrfile_xtc.c - -# Objects - -OBJECTS=$(XDR_SOURCES:.c=.o) - -# Specific rules - -all: $(TARGET) - -$(TARGET): $(OBJECTS) - -$(DEL_FILE) $(TARGET) - $(AR) $(TARGET) $(OBJECTS) - -test: $(TARGET) xdrfile_c_test.o - $(CC) -o a.out xdrfile_c_test.c $(TARGET) -lm - ./a.out - -clean: - /bin/rm -f *.o $(TARGET) a.out test.trr test.xtc test.xdr - -uninstall: clean - -# Dependencies -xdrfile.o: xdrfile.c xdrfile.h - -xdrfile_trr.o: xdrfile_trr.c xdrfile_trr.h xdrfile.h - -xdrfile_xtc.o: xdrfile_xtc.c xdrfile_xtc.h xdrfile.h - -xdr_seek.o: xdr_seek.c xdr_seek.h xdrfile.h - -xdrfile_c_test.o: xdrfile_c_test.c xdrfile_xtc.h xdrfile_trr.h xdrfile.h diff --git a/test/Makefile b/test/Makefile index 987049251c..1ef45f099d 100644 --- a/test/Makefile +++ b/test/Makefile @@ -350,6 +350,7 @@ test.gromacs: test.ewald: @-cd Test_Ewald && ./RunTest.sh $(OPT) + @-cd Test_LibPME && ./RunTest.sh $(OPT) test.ti: @-cd Test_TI && ./RunTest.sh $(OPT) @@ -586,7 +587,7 @@ test.cuda: $(MAKE) test.complete summary OPT="$(OPT) cuda" test.libcpptraj: - @-cd Test_Libcpptraj && ./RunTest.sh $(OPT) + @cd Test_Libcpptraj && ./RunTest.sh $(OPT) test.complete: CpptrajTest.sh MasterTest.sh @./CpptrajTest.sh --target test.cpptraj $(OPT) diff --git a/test/MasterTest.sh b/test/MasterTest.sh index ddc5a1ff85..38b75d5445 100644 --- a/test/MasterTest.sh +++ b/test/MasterTest.sh @@ -37,6 +37,7 @@ # CPPTRAJ_ZLIB : If set CPPTRAJ has zlib support. # CPPTRAJ_BZLIB : If set CPPTRAJ has bzip support. # CPPTRAJ_NETCDFLIB : If set CPPTRAJ has NetCDF support. +# CPPTRAJ_LIBPME : If set CPPTRAJ was compiled with libPME. # CPPTRAJ_MPILIB : If set CPPTRAJ has MPI support. # CPPTRAJ_MATHLIB : If set CPPTRAJ was compiled with math libraries. # CPPTRAJ_OPENMP : If set CPPTRAJ has OpenMP support. @@ -443,6 +444,23 @@ Summary() { exit $ERR_STATUS } +# ------------------------------------------------------------------------------ +# ProgramError() +ProgramError() { + if [ -z "$CPPTRAJ_DACDIF" ] ; then + echo "Error: $1" > /dev/stderr + OutBoth "Error: $1" + else + if [ -z "$2" ] ; then + PNAME=$CPPTRAJ + else + PNAME=$2 + fi + echo "$PNAME: Program error" + fi + ((PROGERROR++)) +} + # ------------------------------------------------------------------------------ # RunCpptraj() # Run cpptraj test with given title. @@ -464,13 +482,7 @@ RunCpptraj() { STATUS=$? #echo "DEBUG: Cpptraj exited with status $STATUS" if [ $STATUS -ne 0 ] ; then - if [ -z "$CPPTRAJ_DACDIF" ] ; then - echo "Error: cpptraj exited with status $STATUS" > /dev/stderr - OutBoth "Error: cpptraj exited with status $STATUS" - else - echo "$CPPTRAJ: Program error" - fi - ((PROGERROR++)) + ProgramError "cpptraj exited with status $STATUS" fi } @@ -691,6 +703,7 @@ CheckDefines() { '-DHASGZ' ) export CPPTRAJ_ZLIB=$DEFINE ;; '-DHASBZ2' ) export CPPTRAJ_BZLIB=$DEFINE ;; '-DBINTRAJ' ) export CPPTRAJ_NETCDFLIB=$DEFINE ;; + '-DLIBPME' ) export CPPTRAJ_LIBPME=$DEFINE ;; '-DMPI' ) export CPPTRAJ_MPILIB=$DEFINE ;; '-DNO_MATHLIB' ) CPPTRAJ_MATHLIB='' ;; '-D_OPENMP' ) export CPPTRAJ_OPENMP=$DEFINE ;; @@ -916,6 +929,7 @@ CheckEnv() { #echo "DEBUG: $DESCRIP: Checking requirement: $1" case "$1" in 'netcdf' ) TestLibrary "NetCDF" "$CPPTRAJ_NETCDFLIB" ;; + 'libpme' ) TestLibrary "libPME" "$CPPTRAJ_LIBPME" ;; 'zlib' ) TestLibrary "Zlib" "$CPPTRAJ_ZLIB" ;; 'bzlib' ) TestLibrary "Bzlib" "$CPPTRAJ_BZLIB" ;; 'xdr' ) TestLibrary "XDR file" "$CPPTRAJ_XDRFILE" ;; @@ -1185,7 +1199,7 @@ if [ -z "$CPPTRAJ_TEST_SETUP" ] ; then export CPPTRAJ_DACDIF export CPPTRAJ_DIFF # If not cleaning see what else needs to be set up. - if [ $CPPTRAJ_TEST_CLEAN -eq 0 ] ; then + if [ $CPPTRAJ_TEST_CLEAN -eq 0 -a -z "$IS_LIBCPPTRAJ" ] ; then # Determine binary locations SetBinaries # If CPPTRAJ_TEST_OS is not set, try to determine. diff --git a/test/Test_Energy/RunTest.sh b/test/Test_Energy/RunTest.sh index fbbc75d498..62fa94fd72 100755 --- a/test/Test_Energy/RunTest.sh +++ b/test/Test_Energy/RunTest.sh @@ -2,11 +2,11 @@ . ../MasterTest.sh -CleanFiles ene.in ene.agr +CleanFiles ene.in ene.agr short.dat INPUT="-i ene.in" -TESTNAME='Simple energy test' +TESTNAME='Simple energy tests' Requires netcdf cat > ene.in <<EOF @@ -17,5 +17,16 @@ EOF RunCpptraj "$TESTNAME" DoTest ene.agr.save ene.agr +UNITNAME='Test kinetic energy calculation' +CheckFor maxthreads 2 +if [ $? -eq 0 ] ; then + cat > ene.in <<EOF +parm ../tz2.nhe.parm7 +trajin ../Test_VelFrc/short.crd mdvel ../Test_VelFrc/short.vel mdfrc ../Test_VelFrc/short.frc +energy kinetic Short out short.dat dt 0.002 +EOF + RunCpptraj "$UNITNAME" + DoTest short.dat.save short.dat +fi EndTest exit 0 diff --git a/test/Test_Energy/short.dat.save b/test/Test_Energy/short.dat.save new file mode 100644 index 0000000000..540eb5c03c --- /dev/null +++ b/test/Test_Energy/short.dat.save @@ -0,0 +1,3 @@ +#Frame Short[kinetic] + 1 176.9080 + 2 166.7480 diff --git a/test/Test_Ewald/RunTest.sh b/test/Test_Ewald/RunTest.sh index 883b84c8e5..7450ac3aaa 100755 --- a/test/Test_Ewald/RunTest.sh +++ b/test/Test_Ewald/RunTest.sh @@ -17,7 +17,7 @@ Direct() { noprogress parm nacl.box.parm7 trajin nacl.box.rst7 -energy out directsum.0 etype directsum npoints 10 +energy elec out directsum.0 etype directsum npoints 10 EOF RunCpptraj "$UNITNAME" DoTest directsum.0.save directsum.0 @@ -32,7 +32,7 @@ NaCl() { noprogress parm nacl.box.parm7 trajin nacl.box.rst7 -energy out ewald.dat etype ewald cut 5.6 dsumtol 0.0000001 \ +energy elec out ewald.dat etype ewald cut 5.6 dsumtol 0.0000001 \ rsumtol 0.0000001 skinnb 0.01 EOF RunCpptraj "$UNITNAME" @@ -48,7 +48,7 @@ Trpzip() { noprogress parm ../tz2.truncoct.parm7 trajin ../tz2.truncoct.nc 1 1 -energy out ew_tz2.dat etype ewald skinnb 0.01 +energy elec out ew_tz2.dat etype ewald skinnb 0.01 EOF RunCpptraj "$UNITNAME" DoTest ew_tz2.dat.save ew_tz2.dat @@ -63,7 +63,7 @@ Tz2_10() { noprogress parm ../tz2.truncoct.parm7 trajin ../tz2.truncoct.nc -energy out ew_tz2_10.dat etype ewald skinnb 0.01 +energy elec out ew_tz2_10.dat etype ewald skinnb 0.01 EOF RunCpptraj "$UNITNAME" DoTest ew_tz2_10.dat.save ew_tz2_10.dat @@ -78,7 +78,7 @@ Ortho() { noprogress parm ../tz2.ortho.parm7 trajin ../tz2.ortho.nc -energy out tz2_ortho.dat etype ewald skinnb 0.01 +energy elec out tz2_ortho.dat etype ewald skinnb 0.01 EOF RunCpptraj "Ewald test (ortho), 10 frames" DoTest tz2_ortho.dat.save tz2_ortho.dat diff --git a/test/Test_Ewald/directsum.0.save b/test/Test_Ewald/directsum.0.save index 6f87257d95..71183e6b03 100644 --- a/test/Test_Ewald/directsum.0.save +++ b/test/Test_Ewald/directsum.0.save @@ -1,2 +1,2 @@ -#Frame ENE_00001[elec] ENE_00001[total] - 1 -6584.7682 -6584.7682 +#Frame ENE_00001[elec] + 1 -6584.7682 diff --git a/test/Test_Ewald/ew_tz2.dat.save b/test/Test_Ewald/ew_tz2.dat.save index 656a6268b2..783ff41b7a 100644 --- a/test/Test_Ewald/ew_tz2.dat.save +++ b/test/Test_Ewald/ew_tz2.dat.save @@ -1,2 +1,2 @@ -#Frame ENE_00001[elec] ENE_00001[total] - 1 -21566.6319 -21566.6319 +#Frame ENE_00001[elec] + 1 -21566.6319 diff --git a/test/Test_Ewald/ew_tz2_10.dat.save b/test/Test_Ewald/ew_tz2_10.dat.save index 11744889ac..9c3fe44d5e 100644 --- a/test/Test_Ewald/ew_tz2_10.dat.save +++ b/test/Test_Ewald/ew_tz2_10.dat.save @@ -1,11 +1,11 @@ -#Frame ENE_00001[elec] ENE_00001[total] - 1 -21566.6319 -21566.6319 - 2 -21460.3952 -21460.3952 - 3 -21594.3258 -21594.3258 - 4 -21609.8831 -21609.8831 - 5 -21670.4939 -21670.4939 - 6 -21655.1485 -21655.1485 - 7 -21752.7170 -21752.7170 - 8 -21686.9831 -21686.9831 - 9 -21604.3303 -21604.3303 - 10 -21625.6076 -21625.6076 +#Frame ENE_00001[elec] + 1 -21566.6319 + 2 -21460.3952 + 3 -21594.3258 + 4 -21609.8831 + 5 -21670.4939 + 6 -21655.1485 + 7 -21752.7170 + 8 -21686.9831 + 9 -21604.3303 + 10 -21625.6076 diff --git a/test/Test_Ewald/ewald.dat.save b/test/Test_Ewald/ewald.dat.save index 00af92c6e9..a1de04b142 100644 --- a/test/Test_Ewald/ewald.dat.save +++ b/test/Test_Ewald/ewald.dat.save @@ -1,2 +1,2 @@ -#Frame ENE_00001[elec] ENE_00001[total] - 1 -6584.7751 -6584.7751 +#Frame ENE_00001[elec] + 1 -6584.7751 diff --git a/test/Test_Ewald/tz2_ortho.dat.save b/test/Test_Ewald/tz2_ortho.dat.save index 151c8b8c8a..114004e9ee 100644 --- a/test/Test_Ewald/tz2_ortho.dat.save +++ b/test/Test_Ewald/tz2_ortho.dat.save @@ -1,11 +1,11 @@ -#Frame ENE_00001[elec] ENE_00001[total] - 1 -19800.3447 -19800.3447 - 2 -19660.2584 -19660.2584 - 3 -19834.6527 -19834.6527 - 4 -19754.1980 -19754.1980 - 5 -19766.8482 -19766.8482 - 6 -19763.2566 -19763.2566 - 7 -19745.2165 -19745.2165 - 8 -19856.5651 -19856.5651 - 9 -19799.1765 -19799.1765 - 10 -19771.7694 -19771.7694 +#Frame ENE_00001[elec] + 1 -19800.3447 + 2 -19660.2584 + 3 -19834.6527 + 4 -19754.1980 + 5 -19766.8482 + 6 -19763.2566 + 7 -19745.2165 + 8 -19856.5651 + 9 -19799.1765 + 10 -19771.7694 diff --git a/test/Test_LibPME/RunTest.sh b/test/Test_LibPME/RunTest.sh new file mode 100755 index 0000000000..4127e1d6b0 --- /dev/null +++ b/test/Test_LibPME/RunTest.sh @@ -0,0 +1,167 @@ +#!/bin/bash + +. ../MasterTest.sh + +CleanFiles ene.in ewald.dat debug.nacl.dat nacl.dat debug.tz2n.dat tz2n.dat \ + debug.tz2o.dat tz2o.dat debug.mtz2o.dat mtz2o.dat pme.nacl.dat \ + long_tz2n.dat +INPUT="-i ene.in" +TESTNAME='Particle mesh Ewald tests' +Requires libpme maxthreads 10 +# Set to 1 for debugging purposes +PMEDEBUG=0 +if [ $PMEDEBUG -eq 0 ] ; then + ECMD='#energy' + PREFIX='' +else + ECMD='energy' + PREFIX='debug.' +fi + +Simple() { + UNITNAME='Particle mesh Ewald test (simple)' + CheckFor maxthreads 1 + if [ $? -eq 0 ] ; then + cat > ene.in <<EOF +noprogress +parm test.mol2 +trajin test.mol2 +box x 20 y 20 z 20 alpha 90 beta 90 gamma 90 +energy out ewald.dat etype pme cut 5.6 dsumtol 0.0000001 skinnb 0.01 +#vector UX ucellx +#vector UY ucelly +#vector UZ ucellz +#run +#writedata ucell.mol2 vectraj trajfmt mol2 UX UY UZ +EOF + RunCpptraj "$UNITNAME" + fi +} + +NaCl() { + UNITNAME='Particle mesh Ewald test (NaCl crystal)' + CheckFor maxthreads 1 + if [ $? -eq 0 ] ; then + TFILE="$PREFIX"nacl.dat + cat > ene.in <<EOF +noprogress +parm ../Test_Ewald/nacl.box.parm7 +trajin ../Test_Ewald/nacl.box.rst7 +debug actions $PMEDEBUG +$ECMD Reg nonbond out $TFILE etype ewald cut 5.6 dsumtol 0.0000001 rsumtol 0.000000001 skinnb 0.01 mlimits 12,12,12 + +energy Pme nonbond out $TFILE etype pme cut 5.6 dsumtol 0.0000001 skinnb 0.01 nfft 32,32,32 +EOF + RunCpptraj "$UNITNAME" + if [ $PMEDEBUG -gt 0 ] ; then + grep "DEBUG: Eself" test.out > pme.nacl.dat + DoTest pme.nacl.dat.save pme.nacl.dat + fi + DoTest "$TFILE".save "$TFILE" + fi +} + +TrpzipNonortho() { + UNITNAME='Particle mesh Ewald test (trunc. oct)' + CheckFor netcdf maxthreads 1 + if [ $? -eq 0 ] ; then + TFILE="$PREFIX"tz2n.dat + cat > ene.in <<EOF +noprogress +parm ../tz2.truncoct.parm7 +trajin ../tz2.truncoct.nc 1 1 +#debug actions 1 +$ECMD Reg nonbond out $TFILE etype ewald skinnb 0.01 \ + cut 8.0 dsumtol 0.0000001 rsumtol 0.000000001 +energy Pme nonbond out $TFILE etype pme skinnb 0.01 order 6 \ + cut 8.0 dsumtol 0.0000001 nfft 96,90,90 +precision $TFILE 20 10 +EOF + RunCpptraj "$UNITNAME" + DoTest tz2n.dat.save tz2n.dat + fi +} + +TrpzipOrtho() { + UNITNAME='Particle mesh Ewald test (ortho)' + CheckFor netcdf maxthreads 1 + if [ $? -eq 0 ] ; then + TFILE="$PREFIX"tz2o.dat + cat > ene.in <<EOF +noprogress +parm ../tz2.ortho.parm7 +trajin ../tz2.ortho.nc 1 1 +#debug actions 1 +$ECMD Reg nonbond out $TFILE etype ewald skinnb 0.01 \ + cut 8.0 dsumtol 0.0000001 rsumtol 0.000000001 +energy Pme nonbond out $TFILE etype pme skinnb 0.01 order 6 \ + cut 8.0 dsumtol 0.0000001 nfft 72,90,72 +precision $TFILE 20 10 +EOF + RunCpptraj "$UNITNAME" + DoTest "$TFILE".save "$TFILE" + fi +} + +MaskTz2Ortho() { + UNITNAME='Particle mesh Ewald test (ortho, with mask)' + CheckFor netcdf maxthreads 1 + if [ $? -eq 0 ] ; then + TFILE="$PREFIX"mtz2o.dat + cat > ene.in <<EOF +noprogress +parm ../tz2.ortho.parm7 +trajin ../tz2.ortho.nc 1 1 +#debug actions 1 +$ECMD Reg nonbond out $TFILE etype ewald skinnb 0.01 !:WAT \ + cut 8.0 dsumtol 0.0000001 rsumtol 0.000000001 +energy Pme nonbond out $TFILE etype pme skinnb 0.01 order 6 !:WAT \ + cut 8.0 dsumtol 0.0000001 nfft 72,90,72 +precision $TFILE 20 10 +EOF + RunCpptraj "$UNITNAME" + DoTest "$TFILE".save "$TFILE" + fi +} + +Tz2_Nonortho_10() { + UNITNAME='PME test (trunc. oct), 10 frames' + CheckFor netcdf long + if [ $? -eq 0 ] ; then + cat > ene.in <<EOF +noprogress +parm ../tz2.truncoct.parm7 +trajin ../tz2.truncoct.nc +energy Pme nonbond out long_tz2n.dat etype pme skinnb 2.0 cut 8.0 \ + dsumtol 0.0000001 nfft 72,90,72 +EOF + RunCpptraj "$UNITNAME" + DoTest long_tz2n.dat.save long_tz2n.dat + fi +} + +Tz2_Ortho_10() { + UNITNAME='Ewald test (ortho), 10 frames' + CheckFor netcdf long + if [ $? -eq 0 ] ; then + cat > ene.in <<EOF +noprogress +parm ../tz2.ortho.parm7 +trajin ../tz2.ortho.nc +energy out tz2_ortho.dat etype ewald skinnb 0.01 +EOF + RunCpptraj "Ewald test (ortho), 10 frames" + DoTest tz2_ortho.dat.save tz2_ortho.dat + fi +} + +#Simple +NaCl +TrpzipNonortho +TrpzipOrtho +MaskTz2Ortho +Tz2_Nonortho_10 +#Tz2_Ortho_10 + +EndTest +exit 0 diff --git a/test/Test_LibPME/debug.mtz2o.dat.save b/test/Test_LibPME/debug.mtz2o.dat.save new file mode 100644 index 0000000000..d12a9a3489 --- /dev/null +++ b/test/Test_LibPME/debug.mtz2o.dat.save @@ -0,0 +1,2 @@ +#Frame Reg[vdw] Reg[elec] Reg[total] Pme[vdw] Pme[elec] Pme[total] + 1 -79.1822257987 -943.6536352120 -1022.8358610107 -79.1822257987 -943.6539233292 -1022.8361491279 diff --git a/test/Test_LibPME/debug.nacl.dat.save b/test/Test_LibPME/debug.nacl.dat.save new file mode 100644 index 0000000000..3d36256f75 --- /dev/null +++ b/test/Test_LibPME/debug.nacl.dat.save @@ -0,0 +1,2 @@ +#Frame Reg[vdw] Reg[elec] Reg[total] Pme[vdw] Pme[elec] Pme[total] + 1 378.6621 -6584.7728 -6206.1107 378.6621 -6584.7728 -6206.1107 diff --git a/test/Test_LibPME/debug.tz2o.dat.save b/test/Test_LibPME/debug.tz2o.dat.save new file mode 100644 index 0000000000..542c54ec6a --- /dev/null +++ b/test/Test_LibPME/debug.tz2o.dat.save @@ -0,0 +1,2 @@ +#Frame Reg[vdw] Reg[elec] Reg[total] Pme[vdw] Pme[elec] Pme[total] + 1 2324.6304955823 -19798.1922517629 -17473.5617561806 2324.6304955823 -19798.1987118544 -17473.5682162722 diff --git a/test/Test_LibPME/long_tz2n.dat.save b/test/Test_LibPME/long_tz2n.dat.save new file mode 100644 index 0000000000..8bed6c81fb --- /dev/null +++ b/test/Test_LibPME/long_tz2n.dat.save @@ -0,0 +1,11 @@ +#Frame Pme[vdw] Pme[elec] Pme[total] + 1 2502.5936 -21563.6431 -19061.0495 + 2 2455.6270 -21457.3496 -19001.7226 + 3 2518.4931 -21592.0338 -19073.5407 + 4 2526.1098 -21606.8636 -19080.7538 + 5 2570.6484 -21667.4837 -19096.8353 + 6 2533.3752 -21652.0039 -19118.6287 + 7 2572.0340 -21749.8048 -19177.7708 + 8 2561.9607 -21684.3388 -19122.3780 + 9 2456.2484 -21601.4187 -19145.1703 + 10 2491.7149 -21622.7305 -19131.0156 diff --git a/test/Test_LibPME/mtz2o.dat.save b/test/Test_LibPME/mtz2o.dat.save new file mode 100644 index 0000000000..72c30322df --- /dev/null +++ b/test/Test_LibPME/mtz2o.dat.save @@ -0,0 +1,2 @@ +#Frame Pme[vdw] Pme[elec] Pme[total] + 1 -79.1822257987 -943.6539233292 -1022.8361491279 diff --git a/test/Test_LibPME/nacl.dat.save b/test/Test_LibPME/nacl.dat.save new file mode 100644 index 0000000000..6ebb8e8990 --- /dev/null +++ b/test/Test_LibPME/nacl.dat.save @@ -0,0 +1,2 @@ +#Frame Pme[vdw] Pme[elec] Pme[total] + 1 378.6621 -6584.7728 -6206.1107 diff --git a/test/Test_LibPME/pme.nacl.dat.save b/test/Test_LibPME/pme.nacl.dat.save new file mode 100644 index 0000000000..96ceee0189 --- /dev/null +++ b/test/Test_LibPME/pme.nacl.dat.save @@ -0,0 +1,2 @@ +DEBUG: Eself= -7576.5456431687 Erecip= 1245.5281164010 Edirect= -253.7552556657 Eadjust= 0.0000000000 Evdw= 395.5497730089 +DEBUG: Eself= -7576.5456431687 Erecip= 1245.5281164009 Edirect= -253.7552556657 Eadjust= 0.0000000000 Evdw= 395.5497730089 diff --git a/test/Test_LibPME/tz2n.dat.save b/test/Test_LibPME/tz2n.dat.save new file mode 100644 index 0000000000..4dd4b98b5e --- /dev/null +++ b/test/Test_LibPME/tz2n.dat.save @@ -0,0 +1,2 @@ +#Frame Pme[vdw] Pme[elec] Pme[total] + 1 2502.5935866411 -21563.6269297400 -19061.0333430989 diff --git a/test/Test_LibPME/tz2o.dat.save b/test/Test_LibPME/tz2o.dat.save new file mode 100644 index 0000000000..8637c87f78 --- /dev/null +++ b/test/Test_LibPME/tz2o.dat.save @@ -0,0 +1,2 @@ +#Frame Pme[vdw] Pme[elec] Pme[total] + 1 2324.6304955823 -19798.1987118544 -17473.5682162722 diff --git a/test/Test_LibPME/wat.dimer.mol2 b/test/Test_LibPME/wat.dimer.mol2 new file mode 100644 index 0000000000..be394a495a --- /dev/null +++ b/test/Test_LibPME/wat.dimer.mol2 @@ -0,0 +1,22 @@ +@<TRIPOS>MOLECULE +MOL + 6 4 1 0 0 +SMALL +USER_CHARGES + + +@<TRIPOS>ATOM + 1 OW 2.0000 2.0000 2.0000 ow 1 WAT -0.834000 + 2 H1 2.5000 2.0000 3.0000 hw 1 WAT 0.417000 + 3 H2 1.5000 2.0000 3.0000 hw 1 WAT 0.417000 + 4 OW 0.0000 0.0000 0.0000 ow 2 WAT -0.834000 + 5 H1 0.5000 0.0000 1.0000 hw 2 WAT 0.417000 + 6 H2 -0.5000 0.0000 1.0000 hw 2 WAT 0.417000 +@<TRIPOS>BOND + 1 1 2 1 + 2 1 3 1 + 3 4 5 1 + 4 4 6 1 +@<TRIPOS>SUBSTRUCTURE + 1 WAT 1 TEMP 0 **** **** 0 ROOT + 2 WAT 4 TEMP 0 **** **** 0 ROOT diff --git a/test/Test_Libcpptraj/RunTest.sh b/test/Test_Libcpptraj/RunTest.sh index 40948e6ef6..fd498c05c4 100755 --- a/test/Test_Libcpptraj/RunTest.sh +++ b/test/Test_Libcpptraj/RunTest.sh @@ -1,23 +1,21 @@ #!/bin/bash - +IS_LIBCPPTRAJ='yes' +. ../MasterTest.sh # Clean -for FILE in Makefile Test.cpp a.out ; do - if [ -f "$FILE" ] ; then - rm $FILE - fi -done +CleanFiles Makefile Test.cpp a.out -if [ "$1" = 'clean' ] ; then - exit 0 +TESTNAME='LIBCPPTRAJ linking test.' +echo "" +echo " CPPTRAJ: $TESTNAME" +if [ -z "$CPPTRAJ_DACDIF" ] ; then + OUT " CPPTRAJ: $TESTNAME" fi -echo "**************************************************************" -echo "LIBCPPTRAJ test." - # First determine whether we are part of AmberTools directory -IN_AMBERTOOLS=0 -if [ ! -z "`pwd | grep AmberTools`" ] ; then +if [ $STANDALONE -eq 0 ] ; then IN_AMBERTOOLS=1 +else + IN_AMBERTOOLS=0 fi # Determine location of config.h, needed for compiler vars. @@ -81,24 +79,32 @@ int main(int argc, char **argv) { EOF # Make the test program -echo " Testing compile and link of libcpptraj." make test_libcpptraj if [ "$?" -ne 0 ] ; then - echo "Error: Could not compile with libcpptraj." > /dev/stderr - exit 1 -fi - -# Run the test program. Export library to avoid any issues -export DYLD_FALLBACK_LIBRARY_PATH=$LIBCPPTRAJ_DIR:$DYLD_FALLBACK_LIBRARY_PATH -export LD_LIBRARY_PATH=$LIBCPPTRAJ_DIR:$LD_LIBRARY_PATH -echo " Testing that program compiled with libcpptraj will execute." -VERSION=`./a.out --version | grep Version` -echo "$VERSION" -if [ "$?" -ne 0 -o -z "$VERSION" ] ; then - echo "Error: Could not run program compiled with libcpptraj." > /dev/stderr + ProgramError "Could not compile with libcpptraj." "libcpptraj" exit 1 +else + # Run the test program. Export library to avoid any issues + export DYLD_FALLBACK_LIBRARY_PATH=$LIBCPPTRAJ_DIR:$DYLD_FALLBACK_LIBRARY_PATH + export LD_LIBRARY_PATH=$LIBCPPTRAJ_DIR:$LD_LIBRARY_PATH + VERSION=`./a.out --version` + STATUS=$? + echo "$VERSION" + if [ $STATUS -ne 0 -o -z "$VERSION" ] ; then + ProgramError "Cannot execute program built with libcpptraj" "libcpptraj" + exit 1 + else + # Pseudo DoTest() execution + ((NUMCOMPARISONS++)) + if [ -z "$CPPTRAJ_DACDIF" ] ; then + # Standalone pass. + OUT " LIBCPPTRAJ OK." + else + # AmberTools pass. + echo "PASSED" + fi + fi fi -echo "Test passed." -echo "" +EndTest exit 0 diff --git a/util/Makefile b/util/Makefile index ad638a39b1..27f8a0663b 100644 --- a/util/Makefile +++ b/util/Makefile @@ -4,4 +4,4 @@ include ../config.h all: nproc nproc: nproc.c - $(CC) -o ../test/nproc $(CFLAGS) nproc.c + $(CC) $(DIRECTIVES) -o ../test/nproc $(CFLAGS) nproc.c